diff --git a/Makefile b/Makefile index ad42fd05..4f1db35b 100644 --- a/Makefile +++ b/Makefile @@ -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 diff --git a/benchmarks/gabriel/chibi-prelude.scm b/benchmarks/gabriel/chibi-prelude.scm new file mode 100644 index 00000000..f00697a6 --- /dev/null +++ b/benchmarks/gabriel/chibi-prelude.scm @@ -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))))) diff --git a/benchmarks/gabriel/conform.sch b/benchmarks/gabriel/conform.sch new file mode 100644 index 00000000..dadcc5d9 --- /dev/null +++ b/benchmarks/gabriel/conform.sch @@ -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. ) 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)))))) + + + diff --git a/benchmarks/gabriel/cpstack.sch b/benchmarks/gabriel/cpstack.sch new file mode 100644 index 00000000..6ef109b8 --- /dev/null +++ b/benchmarks/gabriel/cpstack.sch @@ -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)) diff --git a/benchmarks/gabriel/ctak.sch b/benchmarks/gabriel/ctak.sch new file mode 100644 index 00000000..f6c6cbc1 --- /dev/null +++ b/benchmarks/gabriel/ctak.sch @@ -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))))))) + diff --git a/benchmarks/gabriel/dderiv.sch b/benchmarks/gabriel/dderiv.sch new file mode 100644 index 00000000..5e47a0b0 --- /dev/null +++ b/benchmarks/gabriel/dderiv.sch @@ -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 (+ . ), the code +;;; stored under the atom '+ with indicator DERIV will take 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)) + + diff --git a/benchmarks/gabriel/deriv.sch b/benchmarks/gabriel/deriv.sch new file mode 100644 index 00000000..74881b46 --- /dev/null +++ b/benchmarks/gabriel/deriv.sch @@ -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)) + diff --git a/benchmarks/gabriel/destruct.sch b/benchmarks/gabriel/destruct.sch new file mode 100644 index 00000000..bbc4473e --- /dev/null +++ b/benchmarks/gabriel/destruct.sch @@ -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)))))) + diff --git a/benchmarks/gabriel/div.sch b/benchmarks/gabriel/div.sch new file mode 100644 index 00000000..cbdaeb08 --- /dev/null +++ b/benchmarks/gabriel/div.sch @@ -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* '())))))))) diff --git a/benchmarks/gabriel/earley.sch b/benchmarks/gabriel/earley.sch new file mode 100644 index 00000000..d5f90a23 --- /dev/null +++ b/benchmarks/gabriel/earley.sch @@ -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)) diff --git a/benchmarks/gabriel/fft.sch b/benchmarks/gabriel/fft.sch new file mode 100644 index 00000000..92ed55d0 --- /dev/null +++ b/benchmarks/gabriel/fft.sch @@ -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)) + diff --git a/benchmarks/gabriel/graphs.sch b/benchmarks/gabriel/graphs.sch new file mode 100644 index 00000000..7a27c230 --- /dev/null +++ b/benchmarks/gabriel/graphs.sch @@ -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 + '()))))))) diff --git a/benchmarks/gabriel/kanren.sch b/benchmarks/gabriel/kanren.sch new file mode 100644 index 00000000..8d46a91d --- /dev/null +++ b/benchmarks/gabriel/kanren.sch @@ -0,0 +1,6489 @@ +;; smashed into benchmark form by Matthew + +(define errorf error) + +; like cout << arguments << args +; where argument can be any Scheme object. If it's a procedure +; (without args) it's executed rather than printed (like newline) + +(define (cout . args) + (for-each (lambda (x) + (if (procedure? x) (x) (display x))) + args)) + +(define cerr cout) + +(define pntall (lambda v (write v) (newline))) +(define (_pretty-print v) (write v) (newline)) + +(define nl (string #\newline)) + +;; ========================================================================= +;; term.scm +;; ========================================================================= + +; Terms, variables, substitutions, unification +; +; The appropriate prelude (e.g., chez-specific.scm) is assumed. + +; Some terminology related to variables and substitutions +; +; A substitution subst is a finite map { xi -> ti ... } +; where xi is a logic variable. +; ti is a term ::= variable | Scheme-atom | (cons term term) +; We will sometimes call one `component' xi -> ti of a substitution +; a commitment, or a binding, of a variable xi to a term ti. +; +; A variable x is free in the substitution subst if x \not\in Dom(subst) +; +; Given a term t and a substitution subst, a weak reduction +; t -->w t' +; is defined as +; x -->w subst[x] if x is a var and x \in Dom(subst) +; t -->w t otherwise +; +; A strong reduction +; t -->s t' +; is defined as +; x -->s subst[x] if x is a var and x \in Dom(subst) +; (cons t1 t2) -->s (cons t1' t2') +; where t1 -->s t1' t2 -->s t2' +; t -->s t otherwise +; +; The notion of reduction can be extended to substitutions themselves: +; { xi -> ti ...} -->w { xi -> ti' } where ti -> ti' +; ditto for -->s. +; Let -->w* be a reflexive transitive closure of -->w, and +; let -->w! be a fixpoint of -->w. Ditto for -->s* and -->s! +; For acyclic substitutions, the fixpoints exist. +; +; The confluence of the reduction is guaranteed by the particular form +; of the substitution produced by the unifier (the unifier always +; deals with the weak normal forms of submitted terms). +; +; The similarity of the weak normalization with call-by-value and +; the strong normalization with the applicative-order reduction should +; be apparent. +; +; Variable x is called ultimately free if +; x -->w! x' and x' is free in the subtutution in question. +; +; Two ultimately free variables x and y belong to the same equivalence class +; if x -->w! u and y -->w! u +; The (free) variable u is the natural class representative. +; For the purpose of presentation, one may wish for a better representative. +; Given a set of equivalent variables xi -->w! u, +; a pretty representative is a member z of that set such that the +; string name of 'z' is lexicographically smaller than the string names +; of the other variables in that set. +; +; If a variable x is ultimately free in subst and x ->w! u, +; then there is a binding +; v1 -> v2 where both v1 and v2 are variables and v2 ->w! u. Furthermore, +; the set of all such v1 union {u} is the whole equivalence class of x. +; That property is guaranteed by the unifier. That property lets us +; build an inverse index to find the equivalence class of x. +; +; $Id: term.scm,v 4.50 2005/02/12 00:05:27 oleg Exp $ + + +;---------------------------------------- +; A few preliminaries +; LET*-AND: a simplified and streamlined AND-LET*. +; The latter is defined in SRFI-2 + +(define-syntax let*-and + (syntax-rules () + ((_ false-exp () body0 body1 ...) (begin body0 body1 ...)) + ((_ false-exp ((var0 exp0) (var1 exp1) ...) body0 body1 ...) + (let ((var0 exp0)) + (if var0 + (let*-and false-exp ((var1 exp1) ...) body0 body1 ...) + false-exp))))) + +; Regression testing framework +; test-check TITLE TESTED-EXPRESSION EXPECTED-RESULT +; where TITLE is something printable (e.g., a symbol or a string) +; EXPECTED-RESULT and TESTED-EXPRESSION are both expressions. +; The expressions are evaluated and their results are cmpared +; by equal? +; If the results compare, we just print the TITLE. +; Otherwise, we print the TITLE, the TESTED-EXPRESSION, and +; the both results. +(define-syntax test-check + (syntax-rules () + ((_ title tested-expression expected-result) + (begin + (cout "Testing " title nl) + (let* ((expected expected-result) + (produced tested-expression)) + (or (equal? expected produced) + (errorf 'test-check + "Failed: ~a~%Expected: ~a~%Computed: ~a~%" + 'tested-expression expected produced))) + #f)))) + +(define symbol-append + (lambda symbs + (string->symbol + (apply string-append + (map symbol->string symbs))))) + +;---------------------------------------- + + +;; use SRFI-9 records +(define (make-logical-variable name) + (vector 'lv name)) +(define (logical-variable? x) + (and (vector? x) (eq? 'lv (vector-ref x 0)))) +(define (logical-variable-id x) + (vector-ref x 1)) + +(define logical-variable make-logical-variable) +(define var? logical-variable?) + +; Introduction of a logical variable +(define-syntax let-lv + (syntax-rules () + ((_ (id ...) body) + (let ((id (logical-variable 'id)) ...) body)))) + +; The anonymous variable +(define __ (let-lv (_) _)) + +; Another way to introduce logical variables: via distinguished pairs +; (define logical-var-tag (list '*logical-var-tag*)) ; unique for eq? +; (define native-pair? pair?) +; (define logical-variable +; (lambda (id) +; (cons logical-var-tag id))) +; (define var? +; (lambda (x) +; (and (native-pair? x) (eq? (car x) logical-var-tag)))) +; (define logical-variable-id +; (lambda (x) +; (if (var? x) (cdr x) +; (errorf 'logical-variable-id "Invalid Logic Variable: ~s" x)))) +; (define pair? +; (lambda (x) +; (and (native-pair? x) (not (eq? (car x) logical-var-tag))))) + + +; Eigen-variables -- unique symbols that represent universally-quantified +; variables in a term +; For identification, we prefix the name of the eigen-variable with +; the exclamation mark. The mark makes sure the symbol stands out when +; printed. + +(define counter 0) +(define (jensym s) + (set! counter (+ counter 1)) + (string->symbol (string-append "!$gen$!" s (number->string counter)))) + +(define eigen-variable + (lambda (id) + (symbol-append '! id '_ (jensym "x")))) + +(define eigen-var? + (lambda (x) + (and (symbol? x) + (let ((str (symbol->string x))) + (> (string-length str) 2) + (char=? (string-ref str 0) #\!))))) + + +; (eigen (id ...) body) -- evaluate body in the environment +; extended with the bindings of id ... to the corresponding +; eigen-variables +(define-syntax eigen + (syntax-rules () + ((_ (id ...) body) + (let ((id (eigen-variable 'id)) ...) body)))) + +(define (eigen-test) +(test-check 'eigen + (and + (eigen () #t) + (eigen (x) (eigen-var? x)) + (eigen (x y) + (begin (display "eigens: ") (display (list x y)) + (newline) #t))) + #t)) + +;;; ------------------------------------------------------ + +(define commitment cons) +(define commitment->term cdr) +(define commitment->var car) + +(define empty-subst '()) +(define empty-subst? null?) + +(define extend-subst + (lambda (v t subst) + (cons (commitment v t) subst))) + +; get the free vars of a term (a list without duplicates) +(define vars-of + (lambda (term) + (let loop ((term term) (fv '())) + (cond + ((var? term) (if (memq term fv) fv (cons term fv))) + ((pair? term) (loop (cdr term) (loop (car term) fv))) + (else fv))))) + +; Check to see if a var occurs in a term +(define occurs? + (lambda (var term) + (cond + ((var? term) (eq? term var)) + ((pair? term) (or (occurs? var (car term)) (occurs? var (cdr term)))) + (else #f)))) + +; A ground term contains no variables +(define ground? + (lambda (t) + (cond + ((var? t) #f) + ((pair? t) (and (ground? (car t)) (ground? (cdr t)))) + (else #t)))) + +; Given a term v and a subst s, return v', the weak normal form of v: +; v -->w! v' with respect to s +(define subst-in-weak + (lambda (v s) + (cond + ((var? v) + (cond + ((assq v s) => + (lambda (b) (subst-in-weak (commitment->term b) s))) + (else v))) + (else v)))) + +; Given a term v and a subst s, return v', the strong normal form of v: +; v -->s! v' with respect to s +(define subst-in + (lambda (t subst) + (cond + ((var? t) + (let ((c (assq t subst))) + (if c (subst-in (commitment->term c) subst) t))) + ((pair? t) + (cons + (subst-in (car t) subst) + (subst-in (cdr t) subst))) + (else t)))) + + +; ; Given a term v and a subst s, return v', the strong normal form of v: +; ; v -->s! v' with respect to s +; (define subst-vars-recursively +; (lambda (t subst) +; (cond +; ((var? t) +; (cond +; ((assq t subst) => +; (lambda (c) +; (subst-vars-recursively +; (commitment->term c) (remq c subst)))) +; (else t))) +; ((pair? t) +; (cons +; (subst-vars-recursively (car t) subst) +; (subst-vars-recursively (cdr t) subst))) +; (else t)))) + +; (define normalize-subst +; (lambda (subst) +; (map (lambda (c) +; (commitment (commitment->var c) +; (subst-vars-recursively (commitment->term c) subst))) +; subst))) + + +; Sooner or later, we will need to print out a term or do something +; else with it. We have to decide what to do with free variables that +; may be in that term. +; The long experience with Kanren and miniKanren and long discussions +; convinced us that it's best to `display' free variables as +; _.n where n is a number. BTW, we can't just display +; logical-variable-id, because distinct logical variables may have the same +; logical-variable-id. + +; reify:: term -> reified-term +; where reified-term is identical to term if it is ground. +; Otherwise, we replace all free variables in term with _.n symbols +; The 'reverse' in (reverse (vars-of t)) +; just makes the output look as it used to look before. Consider it +(define reify + (lambda (term) + (let ((fv (reverse (vars-of term)))) + (if (null? fv) term ; the term is ground + (let ((renaming ; build the renaming substitution + (let loop ((counter 0) (fv fv)) + (if (null? fv) empty-subst + (extend-subst + (car fv) + (string->symbol + (string-append "_." (number->string counter))) + (loop (+ 1 counter) (cdr fv))))))) + (subst-in term renaming)))))) + + +; we will also need to print the substitution, either in whole or in part +; reify-subst:: list-of-vars subst -> reified-subst +; where list-of-vars is a list of variables to reify, or the empty +; list. In the latter case, all variables from subst are reified. +; reified-subst has a form ((var-name reified-term) ...) +; where var-name, for historical reasons, has the form id.0 +; where `id' is logical-variable-id. + +(define reify-subst + (lambda (vars subst) + (let* ((vars (if (null? vars) (map commitment->var subst) vars)) + (terms (reify (subst-in vars subst)))) + (map (lambda (x y) + (list (string->symbol + (string-append (symbol->string (logical-variable-id x)) + ".0")) + y)) + vars terms)))) + + + + +; (define compose-subst/own-survivors +; (lambda (base refining survivors) +; (let refine ((b* base)) +; (if (null? b*) survivors +; (cons-if-real-commitment +; (commitment->var (car b*)) +; (subst-in (commitment->term (car b*)) refining) +; (refine (cdr b*))))))) +; +; (define compose-subst +; (lambda (base refining) +; (cond +; ((null? base) refining) +; ((null? refining) base) +; (else +; (compose-subst/own-survivors base refining +; (let survive ((r* refining)) +; (cond +; ((null? r*) '()) +; ((assq (commitment->var (car r*)) base) (survive (cdr r*))) +; (else (cons (car r*) (survive (cdr r*))))))))))) + +; Replace a logical variable with the corresponding eigen-variable +; Note: to be really right, universalize should be a scoping predicate, +; something like exists: +; (universalize (term) goal) +; to prove 'goal' in the env where term is universalized. +; In that case, the introduced eigen-variables do not escape. +; Also, perhaps universalize should take a subst and first +; do (subst-in term subst) and then universalize the remaining +; logical variables -- which by that time would surely be free. +(define universalize + (lambda (term) + (let ((fv (vars-of term))) + (let ((subst + (map + (lambda (v) + (commitment v (eigen-variable (logical-variable-id v)))) + fv))) + (subst-in term subst))))) + + +; copy-term TERM -> TERM +; return a TERM that is identical to the input term modulo the replacement +; of variables in TERM with fresh logical variables. +; If a logical variable occurs several times in TERM, the result +; will have the same number of occurrences of the replacement fresh +; variable. +; This is a sort-of dual to universalize, to be used on the other side +; of the implication. It replaces the existential quantification +; (implicit in free logical variables of a term) with the universal +; quantification. +(define copy-term + (lambda (t) + (let* ((fv (vars-of t)) + (subst + (map (lambda (old-var) + (commitment old-var + (logical-variable (logical-variable-id old-var)))) + fv))) + (subst-in t subst)))) + + +; Similar to universalize: makes nicer symbols for variables that look +; nicer when printed. The 'reverse' in (reverse (vars-of t)) +; just makes the output look as it used to look before. Consider it +; a historical accident. +; (define concretize +; (lambda (t) +; (subst-in t +; (let loop ((fv (reverse (vars-of t))) (env '())) +; (cond +; ((null? fv) empty-subst) +; (else (let ((id (logical-variable-id (car fv)))) +; (let ((num (let*-and 0 ((pr (assq id env))) (+ (cdr pr) 1)))) +; (cons (commitment (car fv) (artificial-id id num)) +; (loop (cdr fv) (cons (cons id num) env))))))))))) +; (define artificial-id +; (lambda (t-id num) +; (string->symbol +; (string-append +; (symbol->string t-id) "." (number->string num))))) + + + + + +;------------------------------------------------------- +;;;; This is Oleg's unifier + +; Either t or u may be: +; __ +; free-var +; bound-var +; pair +; other-value +; So, we have in general 25 possibilities to consider. +; actually, a pair or components of a pair can be variable-free +; or not. In the latter case, we have got to traverse them. +; Also, if a term to unify has come from subst, it has special properties, +; which we can exploit. See below. +; +; "Measurements of the dynamic behavior of unification on four real +; programs show that one or both of the arguments are variables about +; 85% of the time [63]. A subroutine call is made only if both arguments +; are nonvariables." (Peter Van Roy, The Wonder Years ...) +; +; Just like in the union-find unification algorithm, we produce +; substitutions in the "triangular form" (see Baader, Snyder, Unification +; Theory). Circularity is detected only at the end (when we do subst-in). + +(define unify + (lambda (t u subst) + (cond + ((eq? t u) subst) ; quick tests first + ((eq? t __) subst) + ((eq? u __) subst) + ((var? t) + (let*-and (unify-free/any t u subst) ((ct (assq t subst))) + (if (var? u) ; ct is a bound var, u is a var + (let*-and (unify-free/bound u ct subst) ((cu (assq u subst))) + (unify-bound/bound ct cu subst)) + (unify-bound/nonvar ct u subst)))) + ((var? u) ; t is not a variable... + (let*-and + (cond + ((pair? t) (unify-free/list u t subst)) + ; t is not a var and is not a pair: it's atomic + (else (extend-subst u t subst))) + ((cu (assq u subst))) + (unify-bound/nonvar cu t subst))) + ((and (pair? t) (pair? u)) + (let*-and #f ((subst (unify (car t) (car u) subst))) + (unify (cdr t) (cdr u) subst))) + (else (and (equal? t u) subst))))) + +; ct is a commitment to a bound variable, u is a atomic or a composite +; value -- but not a variable +(define unify-bound/nonvar + (lambda (ct u subst) + (let ((t (commitment->term ct))) + (cond ; search for the end of ct -> chain + ((eq? t u) subst) + ((var? t) + (let*-and + (cond + ((pair? u) (unify-free/list t u subst)) + ; u is not a var and is not a pair: it's atomic + (else (extend-subst t u subst))) + ((ct (assq t subst))) + (unify-bound/nonvar ct u subst))) + ; t is some simple or composite value. So is u. + ((and (pair? t) (pair? u)) + (let*-and #f ((subst (unify-internal/any (car t) (car u) subst))) + (unify-internal/any (cdr t) (cdr u) subst))) + (else (and (equal? t u) subst)))))) + + +; Just like unify. However, the first term, t, comes from +; an internalized term. We know it can't be __ and can't contain __ + +(define unify-internal/any + (lambda (t u subst) + (cond + ((eq? t u) subst) ; quick tests first + ((eq? u __) subst) + ((var? t) + (let*-and (unify-free/any t u subst) ((ct (assq t subst))) + (if (var? u) ; ct is a bound var, u is a var + (let*-and (unify-free/bound u ct subst) ((cu (assq u subst))) + (unify-bound/bound ct cu subst)) + (unify-bound/nonvar ct u subst)))) + ((var? u) ; t is not a variable... + (let*-and ; It's a part of an internal term + (extend-subst u t subst) ; no further checks needed + ((cu (assq u subst))) + (unify-internals (commitment->term cu) t subst))) + ((and (pair? t) (pair? u)) + (let*-and #f ((subst (unify-internal/any (car t) (car u) subst))) + (unify-internal/any (cdr t) (cdr u) subst))) + (else (and (equal? t u) subst))))) + + +; Unify two already bound variables represented by their commitments +; ct and cu. +; We single out this case because in the future we may wish +; to unify the classes of these variables, by making a redundant +; binding of (commitment->var ct) to (commitment->term cu) or +; the other way around. +; Aside from the above, this function can take advantage of the following +; facts about (commitment->term cx) (where cx is an existing commitment): +; - it is never __ +; - it never contains __ +; Most importantly, if, for example, (commitment->term ct) is a free variable, +; we enter its binding to (commitment->term cu) with fewer checks. +; in particular, we never need to call unify-free/list nor +; unify-free/any as we do need to rebuild any terms. + +(define unify-internals + (lambda (t u subst) + (cond + ((eq? t u) subst) ; quick tests first + ((var? t) + (let*-and (cond ; t is a free variable + ((var? u) + (let*-and (extend-subst t u subst) ((cu (assq u subst))) + (unify-free/bound t cu subst))) + (else ; t is free, u is not a var: done + (extend-subst t u subst))) + ((ct (assq t subst))) + (cond ; t is a bound variable + ((var? u) + (let*-and (unify-free/bound u ct subst) ((cu (assq u subst))) + (unify-bound/bound ct cu subst))) + (else ; unify bound and a value + (unify-internals (commitment->term ct) u subst))))) + ((var? u) ; t is not a variable... + (let*-and (extend-subst u t subst) ((cu (assq u subst))) + (unify-internals (commitment->term cu) t subst))) + ((and (pair? t) (pair? u)) + (let*-and #f ((subst (unify-internals (car t) (car u) subst))) + (unify-internals (cdr t) (cdr u) subst))) + (else (and (equal? t u) subst))))) + +(define unify-bound/bound + (lambda (ct cu subst) + (unify-internals (commitment->term ct) (commitment->term cu) subst))) + + +; t-var is a free variable, u can be anything +; This is analogous to get_variable instruction of Warren Abstract Machine +; (WAM). +; This function is not recursive and always succeeds, +; because unify-free/bound and unify-free/list always succeed. +(define unify-free/any + (lambda (t-var u subst) + (cond + ((eq? u __) subst) + ((var? u) + (let*-and (extend-subst t-var u subst) ((cu (assq u subst))) + (unify-free/bound t-var cu subst))) + ((pair? u) (unify-free/list t-var u subst)) + (else ; u is not a var and is not a pair: it's atomic + (extend-subst t-var u subst))))) + +; On entrance: t-var is free. +; we are trying to unify it with a bound variable (commitment->var cu) +; Chase the binding chain, see below for comments +; This also works somewhat like union-find... +; This function always succeeds. The resulting substitution is either +; identical to the input one, or differs only in the binding to t-var. +; +; Unlike the previous version of the unifier, +; The following code does not introduce the temp variables *a and *d +; It makes substitutions more complex. Therefore, pruning them +; will take a while, and will break up the sharing. Therefore, we +; don't do any pruning. + +(define unify-free/bound + (lambda (t-var cu s) + (let loop ((cm cu)) + (let ((u-term (commitment->term cm))) + (cond + ((eq? u-term t-var) s) + ((var? u-term) + (cond + ((assq u-term s) => loop) + (else (extend-subst t-var u-term s)))) ; u-term is free here + (else (extend-subst t-var u-term s))))))) + +; ((and (pattern-var? tree2) (assq tree2 env)) => ; tree2 is a bound var +; ; binding a free variable to a bound. Search for a substantial binding +; ; or a loop. If we find a loop tree1->tree2->...->tree1 +; ; then we do not enter the binding to tree1, because tree1 is not +; ; actually constrained. +; (lambda (tree2-binding) +; (let loop ((binding tree2-binding)) +; (cond +; ((eq? tree1 (cdr binding)) env) ; loop: no binding needed +; ((and (pattern-var? (cdr binding)) (assq (cdr binding) env)) +; => loop) +; (else (cons (cons tree1 (cdr binding)) env)))))) + +; t-var is a free variable, u-value is a proper or improper +; list, which may be either fully or partially grounded (or not at all). +; We scan the u-value for __, and if, found, replace them with fresh +; variables. We then bind t-var to the term. +; This function is not recursive and always succeeds. +; +; We assume that more often than not u-value does not contain __. +; Therefore, to avoid the wasteful rebuilding of u-value, we +; first scan it for the occurrence of __. If the scan returns negative, +; we can use u-value as it is. + + ; Rebuild lst replacing all anonymous variables with some + ; fresh logical variables + ; If lst contains no anonymous variables, return #f + ; Note that lst itself may be #f -- and yet no contradiction arises. +(define ufl-rebuild-without-anons + (lambda (lst) + (cond + ((eq? lst __) (logical-variable '*anon)) + ((not (pair? lst)) #f) + ((null? (cdr lst)) + (let ((new-car (ufl-rebuild-without-anons (car lst)))) + (and new-car (cons new-car '())))) + (else + (let ((new-car (ufl-rebuild-without-anons (car lst))) + (new-cdr (ufl-rebuild-without-anons (cdr lst)))) + (if new-car + (cons new-car (or new-cdr (cdr lst))) + (and new-cdr (cons (car lst) new-cdr)))))))) + +(define unify-free/list + (lambda (t-var u-value subst) + (extend-subst t-var + (or (ufl-rebuild-without-anons u-value) u-value) + subst))) + +;------------------------------------------------------------------------ +; Tests + +(define (term-tests) + + ; (cout nl "Compositions of substitutions" nl) + ; (let-lv (x y) + ; (test-check 'test-compose-subst-0 + ; (append (unit-subst x y) (unit-subst y 52)) + ; `(,(commitment x y) ,(commitment y 52)))) + + + ; (test-check 'test-compose-subst-1 + ; (let-lv (x y) + ; (equal? + ; (compose-subst (unit-subst x y) (unit-subst y 52)) + ; `(,(commitment x 52) ,(commitment y 52)))) + ; #t) + + ; (test-check 'test-compose-subst-2 + ; (let-lv (w x y) + ; (equal? + ; (let ((s (compose-subst (unit-subst y w) (unit-subst w 52)))) + ; (compose-subst (unit-subst x y) s)) + ; `(,(commitment x 52) ,(commitment y 52) ,(commitment w 52)))) + ; #t) + + ; (test-check 'test-compose-subst-3 + ; (let-lv (w x y) + ; (equal? + ; (let ((s (compose-subst (unit-subst w 52) (unit-subst y w)))) + ; (compose-subst (unit-subst x y) s)) + ; `(,(commitment x w) ,(commitment w 52) ,(commitment y w)))) + ; #t) + + ; (test-check 'test-compose-subst-4 + ; (let-lv (x y z) + ; (equal? + ; (let ((s (compose-subst (unit-subst y z) (unit-subst x y))) + ; (r (compose-subst + ; (compose-subst (unit-subst x 'a) (unit-subst y 'b)) + ; (unit-subst z y)))) + ; (compose-subst s r)) + ; `(,(commitment x 'b) ,(commitment z y)))) + ; #t) + + ; (test-check 'test-compose-subst-5 + ; (concretize-subst + ; (compose-subst + ; (let-lv (x) (unit-subst x 3)) + ; (let-lv (x) (unit-subst x 4)))) + ; '((x.0 . 3) (x.1 . 4))) + + + ; (test-check 'test-compose-subst-5 + ; (let-lv (x y z) + ; (equal? + ; (let ((term `(p ,x ,y (g ,z)))) + ; (let ((s (compose-subst (unit-subst y z) (unit-subst x `(f ,y)))) + ; (r (compose-subst (unit-subst x 'a) (unit-subst z 'b)))) + ; (let ((term1 (subst-in term s))) + ; (write term1) + ; (newline) + ; (let ((term2 (subst-in term1 r))) + ; (write term2) + ; (newline) + ; (let ((sr (compose-subst s r))) + ; (write sr) + ; (newline) + ; (subst-in term sr)))))) + ; (begin + ; `(p (f ,y) ,z (g ,z)) + ; `(p (f ,y) b (g b)) + ; `(,(commitment y 'b) ,(commitment x `(f ,y)) ,(commitment z 'b)) + ; `(p (f ,y) b (g b))))) + ; #t) + + + (test-check 'test-unify/pairs-oleg1 + (let-lv (x y) + (unify `(,x ,4) `(3 ,x) empty-subst)) + #f) + + (test-check 'test-unify/pairs-oleg2 + (let-lv (x y) + (unify `(,x ,x) '(3 4) empty-subst)) + #f) + + (let-lv (x y) + (test-check 'test-unify/pairs-oleg3 + (reify-subst '() (unify `(,x ,y) '(3 4) empty-subst)) + '((y.0 4) (x.0 3)))) + + (let-lv (x y) + (test-check 'test-unify/pairs-oleg4 + (reify-subst '() (unify `(,x 4) `(3 ,y) empty-subst)) + `((y.0 4) (x.0 3)))) + + (let-lv (x y w z) + (test-check 'test-unify/pairs-oleg5 + (reify-subst (list w y x) + (unify `(,x 4 3 ,w) `(3 ,y ,x ,z) empty-subst)) + '((w.0 _.0) (y.0 4) (x.0 3)))) + + (let-lv (x y w z) + (test-check 'test-unify/pairs-oleg6 + (reify-subst (list y x) + (unify `(,x 4) `(,y ,y) empty-subst)) + '((y.0 4) (x.0 4)))) + + (test-check 'test-unify/pairs-oleg7 + (let-lv (x y) + (unify `(,x 4 3) `(,y ,y ,x) empty-subst)) + #f) + + (let-lv (x y w z u) + (test-check 'test-unify/pairs-oleg8 + (reify-subst (list u z y x) + (unify + `(,w (,x (,y ,z) 8)) + `(,w (,u (abc ,u) ,z)) + empty-subst)) + '((u.0 8) (z.0 8) (y.0 abc) (x.0 8)))) + + (let-lv (x y w z u) + (test-check 'test-unify/pairs-oleg8 + (reify-subst (list y x) + (unify `(p (f a) (g ,x)) `(p ,x ,y) empty-subst)) + '((y.0 (g (f a))) (x.0 (f a))))) + + (let-lv (x y w z u) + (test-check 'test-unify/pairs-oleg10 + (reify-subst (list x y) + (unify `(p (g ,x) (f a)) `(p ,y ,x) empty-subst)) + '((x.0 (f a)) (y.0 (g (f a)))))) + + (let-lv (x y w z u) + (test-check 'test-unify/pairs-oleg11 + (reify-subst (list y x z) + (unify + `(p a ,x (h (g ,z))) + `(p ,z (h ,y) (h ,y)) + empty-subst)) + '((y.0 (g a)) (x.0 (h (g a))) (z.0 a)))) + + ; The following loops... + ; (concretize-subst + ; (let-lv (x y) + ; (let* ((s (unify x `(1 ,x) '())) + ; (s (unify y `(1 ,y) s)) + ; (s (unify x y s))) s))) + + + ; (let-lv (x y w z u) + ; (test-check 'test-unify/pairs-oleg12 + ; (concretize-subst ;;; was #f + ; (let ((s (unify `(p ,x ,x) `(p ,y (f ,y)) empty-subst))) + ; (let ((var (map commitment->var s))) + ; (map commitment + ; var + ; (subst-vars-recursively var s))))) + ; `(;,(commitment '*d.0 '()) + ; ,(commitment '*a.0 '(f *a.0)) + ; ;,(commitment '*d.1 '((f . *d.1))) + ; ,(commitment '*d.0 '((f . *d.0))) + ; ;,(commitment '*a.1 'f) + ; ;,(commitment 'y.0 '(f (f . *d.1))) + ; ,(commitment 'y.0 '(f (f . *d.0))) + ; ,(commitment 'x.0 '(f (f . *d.0)))))) + + ; (let-lv (x y w z u) + ; (test-check 'test-unify/pairs-oleg13 + ; (concretize-subst ;;; was #f + ; (let ((s (unify `(p ,x ,x) `(p ,y (f ,y)) empty-subst))) + ; (let ((var (map commitment->var s))) + ; (map commitment + ; var + ; (subst-vars-recursively var s))))) + ; `(;,(commitment '*d.0 '()) + ; ,(commitment '*a.0 '(f *a.0)) + ; ;,(commitment '*d.1 '((f . *d.1))) + ; ,(commitment '*d.0 '((f . *d.0))) + ; ;,(commitment '*a.1 'f) + ; ;,(commitment 'y.0 '(f (f . *d.1))) + ; ,(commitment 'y.0 '(f (f . *d.0))) + ; ,(commitment 'x.0 '(f (f . *d.0)))))) + + ;Baader & Snyder + (test-check 'test-pathological + (list + (let-lv (x0 x1 y0 y1) + (begin + (_pretty-print + (reify-subst '() + (unify + `(h ,x1 (f ,y0 ,y0) ,y1) + `(h (f ,x0 ,x0) ,y1 ,x1) + empty-subst))) + (newline) #t)) + + (let-lv (x0 x1 x2 y0 y1 y2) + (begin + (_pretty-print + (reify-subst '() + (unify + `(h ,x1 ,x2 (f ,y0 ,y0) (f ,y1 ,y1) ,y2) + `(h (f ,x0 ,x0) (f ,x1 ,x1) ,y1 ,y2 ,x2) + empty-subst))) + (newline) #t)) + + (let-lv (x0 x1 x2 x3 x4 y0 y1 y2 y3 y4) + (begin + (_pretty-print + (reify-subst '() + (unify + `(h ,x1 ,x2 ,x3 ,x4 (f ,y0 ,y0) (f ,y1 ,y1) (f ,y2 ,y2) (f ,y3 ,y3) ,y4) + `(h (f ,x0 ,x0) (f ,x1 ,x1) (f ,x2 ,x2) (f ,x3 ,x3) ,y1 ,y2 ,y3 ,y4 ,x4) + empty-subst))) #t))) + (list #t #t #t)) + + + (test-check 'length-of-subst + (let-lv (x y z) + (let* ((subst (unify x `(1 2 3 4 5 ,z) '())) + (subst (unify x `(1 . ,y) subst)) + (subst (unify z 42 subst))) + (reify-subst '() subst))) + '((z.0 42) (y.0 (2 3 4 5 42)) (x.0 (1 2 3 4 5 42)))) + ;'((z.0 . 42) (y.0 2 3 4 5 a*.0) (a*.0 . z.0) (x.0 1 2 3 4 5 a*.0))) + + 10 + ) + + +;; ========================================================================= +;; kanren.scm +;; ========================================================================= + +; The body of KANREN +; +; The appropriate prelude (e.g., chez-specific.scm) is assumed. +; +; $Id: kanren.ss,v 4.50 2005/02/12 00:05:05 oleg Exp $ + +(define-syntax lambda@ + (syntax-rules () + ((_ (formal) body0 body1 ...) (lambda (formal) body0 body1 ...)) + ((_ (formal0 formal1 formal2 ...) body0 body1 ...) + (lambda (formal0) + (lambda@ (formal1 formal2 ...) body0 body1 ...))))) + +(define-syntax at@ + (syntax-rules () + ((_ rator rand) (rator rand)) + ((_ rator rand0 rand1 rand2 ...) (at@ (rator rand0) rand1 rand2 ...)))) + +;(test-check 'test-@-lambda@ +; (at@ (lambda@ (x y z) (+ x (+ y z))) 1 2 3) +; 6) + +;'(test-check 'test-@-lambda@ +; (at@ (lambda@ (x y z) (+ x (+ y z))) 1 2 3) +; 42) + +(define Y + (lambda (f) + ((lambda (u) (u (lambda (x) (lambda (n) ((f (u x)) n))))) + (lambda (x) (x x))))) + +; An attempt to do a limited beta-substitution at macro-expand time +; (define-syntax @ +; (syntax-rules (syntax-rules) +; ((_ (syntax-rules sdata ...) rand0 ...) +; (let-syntax +; ((tempname (syntax-rules sdata ...))) +; (tempname rand0 ...))) +; ((_ rator rand0 rand1 ...) +; (@-simple rator rand0 rand1 ...)))) + + +; Fk = () -> Ans +; Ans = Nil + [Subst,Fk] or just a conceptual stream of substitutions +; Sk = Subst -> Fk -> Ans +; Goal = Subst -> SGoal +; SGoal = Sk -> Fk -> Ans + +; initial-sk : Sk +; initial-fk : Fk + +(define initial-sk (lambda@ (subst fk) + (cons subst fk))) +(define initial-fk (lambda () '())) + + +; Trivial goals +(define succeed (lambda@ (s k) (at@ k s))) ; eta-reduced +(define fail (lambda@ (s k f) (f))) +(define sfail (lambda@ (k f) (f))) ; Failed SGoal + + +;------------------------------------------------------------------------ +; Making logical variables "scoped" and garbage-collected +; -----> it was used, but no longer +; -----> The code is still here, as we plan to come back to this... +; +; A framework to remove introduced variables when they leave their scope. +; To make removing variables easier, we consider the list of subst as a +; "stack". Before we add a new variable, we retain a pointer to the +; stack. Then, when we are about to remove the added variables after their +; scope is ended, we stop at the shared retained substitution, and we know +; that anything below the retained substitution can't possibly contain the +; reference to the variables we're about to remove. +; +; Pruning of substitutions is analogous to environment pruning (aka tail-call +; optimization) in WAM on _forward_ execution. + +; LV-ELIM IN-SUBST SUBST ID .... +; remove the bindings of ID ... from SUBST (by composing with the +; rest of subst). IN-SUBST is the mark. +; If we locate IN-SUBST in SUBST, we know that everything below the +; mark can't possibly contain ID ... + +; lv-elim-1 VAR IN-SUBST SUBST +; VAR is a logical variable, SUBST is a substitution, and IN-SUBST +; is a tail of SUBST (which may be '()). +; VAR is supposed to have non-complex binding in SUBST +; (see Definition 3 in the document "Properties of Substitutions"). +; If VAR is bound in SUBST, the corresponding commitment +; is supposed to occur in SUBST up to but not including IN-SUBST. +; According to Proposition 10, if VAR freely occurs in SUBST, all such +; terms are VAR itself. +; The result is a substitution with the commitment to VAR removed +; and the other commitments composed with the removed commitment. +; The order of commitments is preserved. + +(define lv-elim-1 + (lambda (var in-subst subst) + (if (eq? subst in-subst) subst + ; if VAR is not bound, there is nothing to prune + (let*-and subst ((var-binding (assq var subst))) + (let ((tv (commitment->term var-binding))) + (let loop ((current subst)) + (cond + ((null? current) current) + ((eq? current in-subst) current) + ((eq? (car current) var-binding) + (loop (cdr current))) + ((eq? (commitment->term (car current)) var) + (cons (commitment (commitment->var (car current)) tv) + (loop (cdr current)))) + (else (cons (car current) (loop (cdr current))))))))))) + +; The same but for multiple vars +; To prune multiple-vars, we can prune them one-by-one +; We can attempt to be more efficient and prune them in parallel. +; But we encounter a problem: +; If we have a substitution +; ((x . y) (y . 1) (a . x)) +; Then pruning 'x' first and 'y' second will give us ((a . 1)) +; Pruning 'y' first and 'x' second will give us ((a . 1)) +; But naively attempting to prune 'x' and 'y' in parallel +; disregarding dependency between them results in ((a . y)) +; which is not correct. +; We should only be concerned about a direct dependency: +; ((x . y) (y . (1 t)) (t . x) (a . x)) +; pruning x and y in sequence or in parallel gives the same result: +; ((t . (1 t)) (a . (1 t))) +; We should also note that the unifier will never return a substitution +; that contains a cycle ((x1 . x2) (x2 . x3) ... (xn . x1)) + +(define lv-elim + (lambda (vars in-subst subst) + (if (eq? subst in-subst) + subst + (let ((var-bindings ; the bindings of truly bound vars + (let loop ((vars vars)) + (if (null? vars) vars + (let ((binding (assq (car vars) subst))) + (if binding + (cons binding (loop (cdr vars))) + (loop (cdr vars)))))))) + (cond + ((null? var-bindings) subst) ; none of vars are bound + ((null? (cdr var-bindings)) + ; only one variable to prune, use the faster version + (lv-elim-1 (commitment->var (car var-bindings)) + in-subst subst)) + ((let test ((vb var-bindings)) ; check multiple dependency + (and (pair? vb) + (or (let ((term (commitment->term (car vb)))) + (and (var? term) (assq term var-bindings))) + (test (cdr vb))))) + ; do pruning sequentially + (let loop ((var-bindings var-bindings) (subst subst)) + (if (null? var-bindings) subst + (loop (cdr var-bindings) + (lv-elim-1 (commitment->var (car var-bindings)) + in-subst subst))))) + (else ; do it in parallel + (let loop ((current subst)) + (cond + ((null? current) current) + ((eq? current in-subst) current) + ((memq (car current) var-bindings) + (loop (cdr current))) + ((assq (commitment->term (car current)) var-bindings) => + (lambda (ct) + (cons (commitment (commitment->var (car current)) + (commitment->term ct)) + (loop (cdr current))))) + (else (cons (car current) (loop (cdr current)))))))))))) + +; when the unifier is moved up, move lv-elim test from below up... + +; That was the code for the unifier that introduced temp variables +; (define-syntax exists +; (syntax-rules () +; ((_ () gl) gl) +; ((_ (ex-id) gl) +; (let-lv (ex-id) +; (lambda@ (sk fk in-subst) +; (at@ gl +; (lambda@ (fk out-subst) +; (at@ sk fk (lv-elim-1 ex-id in-subst out-subst))) +; fk in-subst)))) +; ((_ (ex-id ...) gl) +; (let-lv (ex-id ...) +; (lambda@ (sk fk in-subst) +; (at@ gl +; (lambda@ (fk out-subst) +; (at@ sk fk (lv-elim (list ex-id ...) in-subst out-subst))) +; fk in-subst)))))) + +; For the unifier that doesn't introduce temp variables, +; exists is essentially let-lv +; At present, we don't do any GC. +; Here's the reason we don't do any pruning now: +; Let's unify the variable x with a term `(1 2 3 4 5 ,z). The result +; will be the binding x -> `(1 2 3 4 5 ,z). Let's unify `(1 . ,y) with +; x. The result will be a binding y -> `(2 3 4 5 ,z). Note that the +; bindings of x and y share a tail. Let us now unify z with 42. The +; result will be a binding z->42. So far, so good. Suppose however that +; z now "goes out of scope" (the exists form that introduced z +; finishes). We now have to traverse all the terms in the substitution +; and replace z with its binding. The result will be a substitution +; x -> (1 2 3 4 5 42) +; y -> (2 3 4 5 42) +; Now, the bindings of x and y do not share anything at all! The pruning +; has broke sharing. If we want to unify x and `(1 . ,y) again, we have +; to fully traverse the corresponding terms again. +; So, to prune variables and preserve sharing, we have to topologically sort +; the bindings first! + +(define-syntax _exists + (syntax-rules () + ((_ () gl) gl) + ((_ (ex-id ...) gl) + (let-lv (ex-id ...) gl)) + )) + +;----------------------------------------------------------- +; Sequencing of relations +; Goal is a multi-valued function (which takes +; subst, sk, fk, and exits to either sk or fk). +; A relation is a parameterized goal. +; +; All sequencing operations are defined on goals. +; They can be "lifted" to relations (see below). +; + +; TRACE-GOAL-RAW TITLE GL -> GL +; Traces all invocations and re-invocations of a goal +; printing subst before and after, in their raw form +(define trace-goal-raw + (lambda (title gl) + (let ((print-it + (lambda (event subst) + (display title) (display " ") + (display event) (_pretty-print subst) (newline)))) + (lambda@ (subst sk fk) + (print-it "CALL:" subst) + (at@ gl subst + (lambda@ (subst fk) + (print-it "RETURN:" subst) + (at@ sk subst + (lambda () + (display title) (display " REDO") (newline) + (fk)) + )) + (lambda () + (display title) (display " FAIL") (newline) + (fk)) + ))))) + +; Conjunctions +; All conjunctions below satisfy properties +; ans is an answer of (a-conjunction gl1 gl2 ...) ==> +; forall i. ans is an answer of gl_i +; (a-conjunction) ==> success + + +; (all gl1 gl2 ...) +; A regular Prolog conjunction. Non-deterministic (i.e., can have 0, 1, +; or more answers). +; Properties: +; (all gl) ==> gl +; (all gl1 ... gl_{n-1} gln) is a "join" of answerlists of +; (all gl1 ... gl_{n-1}) and gln + +(define-syntax all + (syntax-rules () + ((_) succeed) + ((_ gl) gl) + ((_ gl0 gl1 ...) + (lambda@ (subst sk) (splice-in-gls/all subst sk gl0 gl1 ...))))) + +(define-syntax splice-in-gls/all + (syntax-rules () + ((_ subst sk gl) (at@ gl subst sk)) + ((_ subst sk gl0 gl1 ...) + (at@ gl0 subst (lambda (subst) (splice-in-gls/all subst sk gl1 ...)))))) + + +; (promise-one-answer gl) +; Operationally, it is the identity. +; It is an optimization directive: if the user knows that an goal +; can produce at most one answer, he can tell the system about it. +; The behavior is undefined if the user has lied. + +(define-syntax promise-one-answer + (syntax-rules () + ((_ gl) gl))) + +; (all! gl1 gl2 ...) +; A committed choice nondeterminism conjunction +; From the Mercury documentation: + +; In addition to the determinism annotations described earlier, there +; are "committed choice" versions of multi and nondet, called cc_multi +; and cc_nondet. These can be used instead of multi or nondet if all +; calls to that mode of the predicate (or function) occur in a context +; in which only one solution is needed. +; +; (all! gl) evaluates gl in a single-choice context. That is, +; if gl fails, (all! gl) fails. If gl has at least one answer, +; this answer is returned. +; (all! gl) has at most one answer regardless of the answers of gl. +; ans is an answer of (all! gl) ==> ans is an answer of gl +; The converse is not true. +; Corollary: (all! gl) =/=> gl +; Corollary: gl is (semi-) deterministic: (all! gl) ==> gl +; (all! (promise-one-answer gl)) ==> gl +; +; By definition, (all! gl1 gl2 ...) ===> (all! (all gl1 gl2 ...)) + +(define-syntax all! + (syntax-rules (promise-one-answer) + ((_) (promise-one-answer (all))) + ((_ (promise-one-answer gl)) (promise-one-answer gl)) ; keep the mark + ((_ gl0 gl1 ...) + (promise-one-answer + (lambda@ (subst sk fk) + (at@ + (splice-in-gls/all subst + (lambda@ (subst fk-ign) (at@ sk subst fk)) gl0 gl1 ...) + fk)))))) + +; (all!! gl1 gl2 ...) +; Even more committed choice nondeterministic conjunction +; It evaluates all elements of the conjunction in a single answer context +; (all!! gl) ==> (all! gl) =/=> gl +; (all!! gl1 gl2 ...) ==> (all (all! gl1) (all! gl2) ...) +; ==> (all! (all! gl1) (all! gl2) ...) +; (all!! gl1 ... gln (promise-one-answer gl)) ==> +; (all (all!! gl1 ... gln) gl) + +(define-syntax all!! + (syntax-rules () + ((_) (all!)) + ((_ gl) (all! gl)) + ((_ gl0 gl1 ...) + (promise-one-answer + (lambda@ (subst sk fk) + (splice-in-gls/all!! subst sk fk gl0 gl1 ...)))))) + +(define-syntax splice-in-gls/all!! + (syntax-rules (promise-one-answer) + ((_ subst sk fk) + (at@ sk subst fk)) + ((_ subst sk fk (promise-one-answer gl)) + (at@ gl subst sk fk)) + ((_ subst sk fk gl0 gl1 ...) + (at@ gl0 subst + (lambda@ (subst fk-ign) (splice-in-gls/all!! subst sk fk gl1 ...)) + fk)))) + +; (if-only COND THEN) +; (if-only COND THEN ELSE) +; Here COND, THEN, ELSE are goals. +; If COND succeeds at least once, the result is equivalent to +; (all (all! COND) TNEN) +; If COND fails, the result is the same as ELSE. +; If ELSE is omitted, it is assumed fail. That is, (if-only COND THEN) +; fails if the condition fails. "This unusual semantics +; is part of the ISO and all de-facto Prolog standards." +; Thus, declaratively, +; (if-only COND THEN ELSE) ==> (any (all (all! COND) THEN) +; (all (fails COND) ELSE)) +; Operationally, we try to generate a good code. + +; "The majority of predicates written by human programmers are +; intended to give at most one solution, i.e., they are +; deterministic. These predicates are in effect case statements +; [sic!], yet they are too often compiled in an inefficient manner +; using the full generality of backtracking (which implies saving the +; machine state and repeated failure and state restoration)." (Peter +; Van Roy, 1983-1993: The Wonder Years of Sequential Prolog +; Implementation). + + +(define-syntax if-only + (syntax-rules () + ((_ condition then) + (lambda@ (subst sk fk) + (at@ condition subst + ; sk from cond + (lambda@ (subst fk-ign) (at@ then subst sk fk)) + ; failure from cond + fk))) + ((_ condition then else) + (lambda@ (subst sk fk) + (at@ condition subst + (lambda@ (subst fk-ign) (at@ then subst sk fk)) + (lambda () (at@ else subst sk fk)) + ))))) + +; (if-all! (COND1 ... CONDN) THEN) +; (if-all! (COND1 ... CONDN) THEN ELSE) +; +; (if-all! (COND1 ... CONDN) THEN ELSE) ==> +; (if-only (all! COND1 ... CONDN) THEN ELSE) +; (if-all! (COND1) THEN ELSE) ==> +; (if-only COND1 THEN ELSE) + +; Eventually, it might be a recognized special case in if-only. + +; (define-syntax if-all! +; (syntax-rules () +; ((_ (condition) then) (if-only condition then)) +; ((_ (condition) then else) (if-only condition then else)) +; ((_ (condition1 condition2 ...) then) +; (lambda@ (sk fk) +; (@ (splice-in-gls/all +; (lambda@ (fk-ign) +; (@ then sk fk)) +; condition1 condition2 ...) +; fk))) +; ((_ (condition1 condition2 ...) then else) +; (lambda@ (sk fk subst) +; (@ (splice-in-gls/all +; (lambda@ (fk-ign) +; (@ then sk fk)) condition1 condition2 ...) +; (lambda () +; (@ else sk fk subst)) +; subst))))) + +; Disjunction of goals +; All disjunctions below satisfy properties +; ans is an answer of (a-disjunction gl1 gl2 ...) ==> +; exists i. ans is an answer of gl_i +; (a-disjunction) ==> fail + +; Any disjunction. A regular Prolog disjunction (introduces +; a choicepoints, in Prolog terms) +; Note that 'any' is not a union! In particular, it is not +; idempotent. +; (any) ===> fail +; (any gl) ===> gl +; (any gl1 ... gln) ==> _concatenation_ of their answerlists + +(define-syntax any + (syntax-rules () + ((_) fail) + ((_ gl) gl) + ((_ gl ...) + (lambda@ (subst sk fk) + (splice-in-gls/any subst sk fk gl ...))))) + +(define-syntax splice-in-gls/any + (syntax-rules () + ((_ subst sk fk gl1) (at@ gl1 subst sk fk)) + ((_ subst sk fk gl1 gl2 ...) + (at@ gl1 subst sk (lambda () (splice-in-gls/any subst sk fk gl2 ...)))))) + + +; Negation +; (fails gl) succeeds iff gl has no solutions +; (fails gl) is a semi-deterministic predicate: it can have at most +; one solution +; (succeeds gl) succeeds iff gl has a solution +; +; (fails (fails gl)) <===> (succeeds gl) +; but (succeeds gl) =/=> gl +; Cf. (equal? (not (not x)) x) is #f in Scheme in general. +; Note, negation is only sound if some rules (Grounding Rules) are satisfied. + +(define fails + (lambda (gl) + (lambda@ (subst sk fk) + (at@ gl subst + (lambda@ (subst current-fk) (fk)) + (lambda () (at@ sk subst fk)) + )))) + +; Again, G-Rule must hold for this predicate to be logically sound +(define succeeds + (lambda (gl) + (lambda@ (subst sk fk) + (at@ gl subst (lambda@ (subst-ign fk-ign) (at@ sk subst fk)) + fk)))) + +; partially-eval-sgl: Partially evaluate a semi-goal. A +; semi-goal is an expression that, when applied to two +; arguments, sk and fk, can produce zero, one, or more answers. Any +; goal can be turned into a semi-goal if partially applied +; to subst. The following higher-order semi-goal takes a +; goal and yields the first answer and another, residual +; goal. The latter, when evaluated, will give the rest of the +; answers of the original semi-goal. partially-eval-sgl could +; be implemented with streams (lazy lists). The following is a purely +; combinational implementation. +; +; (at@ partially-eval-sgl sgl a b) => +; (b) if sgl has no answers +; (a s residial-sgl) if sgl has a answer. That answer is delivered +; in s. +; The residial semi-goal can be passed to partially-eval-sgl +; again, and so on, to obtain all answers from a goal one by one. + +; The following definition is eta-reduced. + +(define (partially-eval-sgl sgl) + (at@ sgl + (lambda@ (subst fk a b) + (at@ a subst + (lambda@ (sk1 fk1) + (at@ + (fk) + ; new a + (lambda@ (sub11 x) (at@ sk1 sub11 (lambda () (at@ x sk1 fk1)))) + ; new b + fk1)))) + (lambda () (lambda@ (a b) (b))))) + +; An interleaving disjunction. +; Declaratively, any-interleave is the same as any. +; Operationally, any-interleave schedules each component goal +; in round-robin. So, any-interleave is fair: it won't let a goal +; that produces infinitely many answers (such as repeat) starve the others. +; any-interleave introduces a breadth-first-like traversal of the +; decision tree. +; I seem to have seen a theorem that says that a _fair_ scheduling +; (like that provided by any-interleave) entails a minimal or well-founded +; semantics of a Prolog program. + +(define-syntax any-interleave + (syntax-rules () + ((_) fail) + ((_ gl) gl) + ((_ gl ...) + (lambda@ (subst sk fk) + (interleave sk fk (list (gl subst) ...)))))) + +; we treat sgls as a sort of a circular list +(define interleave + (lambda (sk fk sgls) + (cond + ((null? sgls) (fk)) ; all of the sgls are finished + ((null? (cdr sgls)) + ; only one of sgls left -- run it through the end + (at@ (car sgls) sk fk)) + (else + (let loop ((curr sgls) (residuals '())) + ; check if the current round is finished + (if (null? curr) (interleave sk fk (reverse residuals)) + (at@ + partially-eval-sgl (car curr) + ; (car curr) had an answer + (lambda@ (subst residual) + (at@ sk subst + ; re-entrance cont + (lambda () (loop (cdr curr) (cons residual residuals))))) + ; (car curr) is finished - drop it, and try next + (lambda () (loop (cdr curr) residuals))))))))) + +; An interleaving disjunction removing duplicates: any-union +; This is a true union of the constituent goals: it is fair, and +; it removes overlap in the goals to union, if any. Therefore, +; (any-union gl gl) ===> gl +; whereas (any gl gl) =/=> gl +; because the latter has twice as many answers as gl. +; +; Any-union (or interleave-non-overlap, to be precise) is quite similar +; to the function interleave above. But now, the order of goals +; matters. Given goals gl1 gl2 ... glk ... gln, +; at the k-th step we try to partially-eval glk. If it yields an answer, +; we check if gl_{k+1} ... gln can be satisfied with that answer. +; If any of them does, we disregard the current answer and ask glk for +; another one. We maintain the invariant that +; ans is an answer of (any-union gl1 ... gln) +; ===> exists i. ans is an answer of gl_i +; && forall j>i. ans is not an answer of gl_j +; The latter property guarantees the true union. +; Note the code below does not check if the answers of each individual +; goal are unique. It is trivial to modify the code so that +; any-union removes the duplicates not only among the goals but +; also within a goal. That change entails a run-time cost. More +; importantly, it breaks the property +; (any-union gl gl) ===> gl +; Only a weaker version, (any-union' gl gl) ===> (any-union' gl) +; would hold. Therefore, we do not make that change. + +(define-syntax any-union + (syntax-rules () + ((_) fail) + ((_ gl) gl) + ((_ gl ...) + (lambda@ (subst sk fk) + (interleave-non-overlap sk fk (list (cons (gl subst) gl) ...)))))) + +; we treat sagls as a sort of a circular list +; Each element of sagls is a pair (sgl . gl) +; where gl is the original goal (needed for the satisfiability testing) +; and sgl is the corresponding semi-goal or a +; residual thereof. +(define interleave-non-overlap + (lambda (sk fk sagls) + (let outer ((sagls sagls)) + (cond + ((null? sagls) (fk)) ; all of the sagls are finished + ((null? (cdr sagls)) ; only one gl is left -- run it through the end + (at@ (caar sagls) sk fk)) + (else + (let loop ((curr sagls) + (residuals '())) + ; check if the current round is finished + (if (null? curr) (outer (reverse residuals)) + (at@ + partially-eval-sgl (caar curr) + ; (caar curr) had an answer + (lambda@ (subst residual) + ; let us see now if the answer, subst, satisfies any of the + ; gls down the curr. + (let check ((to-check (cdr curr))) + (if (null? to-check) ; OK, subst is unique,give it to user + (at@ sk subst + ; re-entrance cont + (lambda () + (loop (cdr curr) + (cons (cons residual (cdar curr)) residuals)))) + (at@ (cdar to-check) subst + ; subst was the answer to some other gl: + ; check failed + (lambda@ (subst1 fk1) + (loop (cdr curr) + (cons (cons residual (cdar curr)) residuals))) + ; subst was not the answer: continue check + (lambda () (check (cdr to-check))))))) + ; (car curr) is finished - drop it, and try next + (lambda () (loop (cdr curr) residuals)))))))))) + + +; Another if-then-else +; (if-some COND THEN) +; (if-some COND THEN ELSE) +; Here COND, THEN, ELSE are goals. +; If COND succeeds at least once, the result is equivalent to +; (all COND TNEN) +; If COND fails, the result is the same as ELSE. +; If ELSE is omitted, it is assumed fail. That is, (if-some COND THEN) +; fails if the condition fails. "This unusual semantics +; is part of the ISO and all de-facto Prolog standards." +; Thus, declaratively, +; (if-some COND THEN ELSE) ==> (any (all COND THEN) +; (all (fails COND) ELSE)) +; from which follows +; (if-some COND THEN) ==> (all COND THEN) +; (if-some COND THEN fail) ==> (all COND THEN) +; but +; (if-some COND succeed ELSE) =/=> (any COND ELSE) +; +; Other corollary: +; (if-some COND THEN ELSE) ==> (if-only (fails COND) ELSE (all COND THEN)) +; +; Operationally, we try to generate a good code. +; +; In Prolog, if-some is called a soft-cut (aka *->). In Mercury, +; if-some is the regular IF-THEN-ELSE. +; +; We can implement if-some with partially-eval-sgl. Given a COND, we +; peel off one answer, if possible. If there is one, we then execute THEN +; passing it the answer and the fk from COND so that if THEN fails, +; it can obtain another answer. If COND has no answers, we execute +; ELSE. Again, we can do all that purely declaratively, without +; talking about introducing and destroying choice points. + +(define-syntax if-some + (syntax-rules () + ((_ condition then) (all condition then)) + ((_ condition then else) + (lambda@ (subst sk fk) + (at@ partially-eval-sgl (condition subst) + (lambda@ (ans residual) + (at@ then ans sk + ; then failed. Check to see if condition has another answer + (lambda () (at@ residual (lambda@ (subst) (at@ then subst sk)) fk)))) + ; condition failed + (lambda () (at@ else subst sk fk))))))) + + +; An interleaving conjunction: all-interleave +; +; This conjunction is similar to the regular conjunction `all' but +; delivers the answers in the breadth-first rather than depth-first +; order. +; +; Motivation. +; Let us consider the conjunction (all gl1 gl2) +; where gl1 is (any gl11 gl12) and gl2 is an goal with the +; infinite number of answers (in the environment when either gl11 or +; gl12 succeed). It is easy to see (all gl1 gl2) will have the +; infinite number of answers too -- but only the proper subset of +; all the possible answers. Indeed, (all gl1 gl2) will essentially +; be equivalent to (all gl11 gl2). Because gl2 succeeds infinitely +; many times, the choice gl12 in gl1 will never be explored. +; We can see that formally: +; (all gl1 gl2) +; = (all (any gl11 gl12) gl2) +; = (any (all gl11 gl2) (all gl12 gl2)) +; Because (all gl11 gl2) can succeed infinitely many times, it starves +; the other disjunction, (all gl12 gl2). +; But we know how to deal with that: we just replace any with any-interleave: +; (all gl1 gl2) --> (any-interleave (all gl11 gl2) (all gl12 gl2)) +; +; It seems that the problem is solved? We just re-write our expressions +; into the disjunctive normal form, and then replace the top-level +; `any' with `any-interleave'. Alas, that means that to get the benefit +; of fair scheduling and get all the possible solutions of the conjunction +; (i.e., recursive enumerability), we need to re-write all the code. +; We have to explicitly re-write a conjunction of disjunctions into +; the disjunctive normal form. That is not that easy considering that gl2 +; will most likely be a recursive goal re-invoking the original +; conjunction. That would be a lot of re-writing. +; +; The conjunction all-interleave effectively does the above `re-writing' +; That is, given the example above, +; (all-interleave (any gl11 gl12) gl2) +; is observationally equivalent to +; (any-interleave (all gl11 gl2) (all gl12 gl2)) +; +; The advantage is that we do not need to re-write our conjunctions: +; we merely replace `all' with `all-interleave.' +; +; How can we do that in the general case, (all gl1 gl2) +; where gl1 is not _explicitly_ a disjunction? We should remember the +; property of partially-eval-sgl: Any goal `gl' with at least one +; answer can be represented as (any gl-1 gl-rest) +; where gl-1 is a primitive goal holding the first answer of `gl', +; and gl-rest holding the rest of the answers. We then apply the +; all-any-distributive law and re-write +; (all-interleave gl1 gl2) +; ==> (all-interleave (any gl1-1 gl1-rest) gl2) +; ==> (any-interleave (all gl1 gl2) (all-interleave gl1-rest gl2)) +; +; If gl1 has no answers, then (all-interleave gl1 gl2) fails, as +; a conjunction must. +; It is also easy to see that +; (all-interleave gl1 gl2 ...) is the same as +; (all-interleave gl1 (all-interleave gl2 ...)) +; +; Although all-interleave was motivated by an example (all gl1 gl2) +; where gl1 is finitary and only gl2 is infinitary, the above +; equations (and the implementation below) show that all-interleave +; can do the right thing even if gl1 is infinitary as well. To be +; precise, given +; +; (all-interleave gl1 gl2) +; +; with gl1 and gl2 infinitary, the i-th solution of gl1 will be +; observed in every 2^i-th solution to the whole conjunction. Granted, +; all-interleave isn't precisely very fair -- the later solutions of +; gl1 will appear progressively more rarely -- yet, they will all +; appear. The infinity of c0 is big enough. That is, given any +; solution to gl1, we will eventually, in finite time, find it in the +; solution of the whole conjunction (provided gl2 doesn't fail on +; that solution, of course). + + + +(define-syntax all-interleave + (syntax-rules () + ((_) (all)) + ((_ gl) gl) + ((_ gl0 gl1 ...) + (lambda@ (subst) + (all-interleave-bin + (gl0 subst) (all-interleave gl1 ...)))))) + +(define all-interleave-bin + (lambda (sgl1 gl2) + (lambda@ (sk fk) + (at@ partially-eval-sgl sgl1 + (lambda@ (ans residual) + (interleave sk fk + (list + (at@ gl2 ans) + (all-interleave-bin residual gl2) + ))) + ;gl1 failed + fk)))) + + +; Relations........................... + +; The current incremented unification of argument passing is quite similar to +; the compilation of argument unifications in WAM. + +; relation (VAR ...) (to-show TERM ...) [GL] +; Defines a relation of arity (length '(TERM ...)) with an optional body +; GL. VAR ... are logical variables that are local to the relation, i.e., +; appear in TERM or GL. It's better to list as VAR ... only logical +; variables that appear in TERM. Variables that appear only in GL should +; be introduced with exists. That makes their existential quantification +; clearer. Variables that appear in TERM are universally quantified. +; +; relation (head-let TERM ...) [GL] +; See relation-head-let below. +; +; relation (ANNOT-VAR ...) (to-show TERM ...) [GL] (see remark below!) +; where ANNOT-VAR is either a simple VAR or (once VAR) +; where 'once' is a distingushed symbol. The latter form introduces +; a once-var, aka linear variable. A linear variable appears only once in +; TERM ... and only at the top level (that is, one and only one TERM +; in the to-show pattern contains ONCE-VAR, and that term is ONCE-VAR +; itself). In addition, ONCE-VAR must appear at most once in the body GL. +; (Of course, then ONCE-VAR could be _, instead.) +; If these conditions are satisfied, we can replace a logical variable +; ONCE-VAR with a regular Scheme variable. + +; Alternative notation: +; (relation (a c) (to-show term1 (once c) term2) body) +; Makes it easier to deal with. But it is unsatisfactory: +; to-show becomes a binding form... +; +; When ``compiling'' a relation, we now look through the +; (to-show ...) pattern for a top-level occurrence of the logical variable +; introduced by the relation. For example: +; (relation (x y) (to-show `(,x . ,y) x) body) +; we notice that the logical variable 'x' occurs at the top-level. Normally we +; compile the relation like that into the following +; (lambda (g1 g2) +; (_exists (x y) +; (lambda@ (subst) +; (let*-and (fail subst) ((subst (unify g1 `(,x . ,y) subst)) +; (subst (unify g2 x subst))) +; (at@ body subst))))) +; +; However, that we may permute the order of 'unify g...' clauses +; to read +; (lambda (g1 g2) +; (_exists (x y) +; (lambda@ (subst) +; (let*-and (fail subst) ((subst (unify x g2 subst)) +; (subst (unify g1 `(,x . ,y) subst)) +; ) +; (at@ body subst))))) +; +; We may further note that according to the properties of the unifier +; (see below), (unify x g2 subst) must always succeed, +; because x is a fresh variable. +; Furthermore, the result of (unify x g2 subst) is either subst itself, +; or subst with the binding of x. Therefore, we can check if +; the binding at the top of (unify x g2 subst) is the binding to x. If +; so, we can remove the binding and convert the variable x from being logical +; to being lexical. Thus, we compile the relation as +; +; (lambda (g1 g2) +; (_exists (x y) +; (lambda@ (subst) +; (let* ((subst (unify-free/any x g2 subst)) +; (fast-path? (and (pair? subst) +; (eq? x (commitment->var (car subst))))) +; (x (if fast-path? (commitment->term (car subst)) x)) +; (subst (if fast-path? (cdr subst) subst))) +; (let*-and sfail ((subst (unify g1 `(,x . ,y) subst)) +; ) +; (at@ body subst)))))) +; +; The benefit of that approach is that we limit the growth of subst and avoid +; keeping commitments that had to be garbage-collected later. + + +(define-syntax relation + (syntax-rules (to-show head-let once __) + ((_ (head-let head-term ...) gl) + (relation-head-let (head-term ...) gl)) + ((_ (head-let head-term ...)) ; not particularly useful without body + (relation-head-let (head-term ...))) + ((_ () (to-show term ...) gl) ; pattern with no vars _is_ linear + (relation-head-let (`,term ...) gl)) + ((_ () (to-show term ...)) ; the same without body: not too useful + (relation-head-let (`,term ...))) + ((_ (ex-id ...) (to-show term ...) gl) ; body present + (relation "a" () () (ex-id ...) (term ...) gl)) + ((_ (ex-id ...) (to-show term ...)) ; no body + (relation "a" () () (ex-id ...) (term ...))) + ; process the list of variables and handle annotations + ((_ "a" vars once-vars ((once id) . ids) terms . gl) + (relation "a" vars (id . once-vars) ids terms . gl)) + ((_ "a" vars once-vars (id . ids) terms . gl) + (relation "a" (id . vars) once-vars ids terms . gl)) + ((_ "a" vars once-vars () terms . gl) + (relation "g" vars once-vars () () () (subst) terms . gl)) + ; generating temp names for each term in the head + ; don't generate if the term is a variable that occurs in + ; once-vars + ; For _ variables in the pattern, generate unique names for the lambda + ; parameters, and forget them + ; also, note and keep track of the first occurrence of a term + ; that is just a var (bare-var) + ((_ "g" vars once-vars (gs ...) gunis bvars bvar-cl (__ . terms) . gl) + (relation "g" vars once-vars (gs ... anon) gunis + bvars bvar-cl terms . gl)) + ((_ "g" vars once-vars (gs ...) gunis bvars (subst . cls) + (term . terms) . gl) + (id-memv?? term once-vars + ; success continuation: term is a once-var + (relation "g" vars once-vars (gs ... term) gunis bvars (subst . cls) + terms . gl) + ; failure continuation: term is not a once-var + (id-memv?? term vars + ; term is a bare var + (id-memv?? term bvars + ; term is a bare var, but we have seen it already: general case + (relation "g" vars once-vars (gs ... g) ((g . term) . gunis) + bvars (subst . cls) terms . gl) + ; term is a bare var, and we have not seen it + (relation "g" vars once-vars (gs ... g) gunis + (term . bvars) + (subst + (subst (unify-free/any term g subst)) + (fast-path? (and (pair? subst) + (eq? term (commitment->var (car subst))))) + (term (if fast-path? (commitment->term (car subst)) term)) + (subst (if fast-path? (cdr subst) subst)) + . cls) + terms . gl)) + ; term is not a bare var + (relation "g" vars once-vars (gs ... g) ((g . term) . gunis) + bvars (subst . cls) terms . gl)))) + ((_ "g" vars once-vars gs gunis bvars bvar-cl () . gl) + (relation "f" vars once-vars gs gunis bvar-cl . gl)) + + ; Final: writing the code + ((_ "f" vars () () () (subst) gl) ; no arguments (no head-tests) + (lambda () + (_exists vars gl))) + ; no tests but pure binding + ((_ "f" (ex-id ...) once-vars (g ...) () (subst) gl) + (lambda (g ...) + (_exists (ex-id ...) gl))) + ; the most general + ((_ "f" (ex-id ...) once-vars (g ...) ((gv . term) ...) + (subst let*-clause ...) gl) + (lambda (g ...) + (_exists (ex-id ...) + (lambda (subst) + (let* (let*-clause ...) + (let*-and sfail ((subst (unify gv term subst)) ...) + (at@ gl subst))))))))) + +; A macro-expand-time memv function for identifiers +; id-memv?? FORM (ID ...) KT KF +; FORM is an arbitrary form or datum, ID is an identifier. +; The macro expands into KT if FORM is an identifier that occurs +; in the list of identifiers supplied by the second argument. +; Otherwise, id-memv?? expands to KF. +; All the identifiers in (ID ...) must be unique. +; Two identifiers match if both refer to the same binding occurrence, or +; (both are undefined and have the same spelling). + +(define-syntax id-memv?? + (syntax-rules () + ((id-memv?? form (id ...) kt kf) + (let-syntax + ((test + (syntax-rules (id ...) + ((test id _kt _kf) _kt) ... + ((test otherwise _kt _kf) _kf)))) + (test form kt kf))))) + +; Test cases +; (id-memv?? x (a b c) #t #f) +; (id-memv?? a (a b c) 'OK #f) +; (id-memv?? () (a b c) #t #f) +; (id-memv?? (x ...) (a b c) #t #f) +; (id-memv?? "abc" (a b c) #t #f) +; (id-memv?? x () #t #f) +; (let ((x 1)) +; (id-memv?? x (a b x) 'OK #f)) +; (let ((x 1)) +; (id-memv?? x (a x b) 'OK #f)) +; (let ((x 1)) +; (id-memv?? x (x a b) 'OK #f)) + + +; relation-head-let (head-term ...) gl +; A simpler, and more efficient kind of relation. The simplicity comes +; from a simpler pattern at the head of the relation. The pattern must +; be linear and shallow with respect to introduced variables. The gl +; is optional (although omitting it doesn't make much sense in +; practice) There are two kinds of head-terms. One kind is an +; identifier. This identifier is taken to be a logical identifier, to +; be unified with the corresponding actual argument. Each logical +; identifier must occur exactly once. Another kind of a head-terms is +; anything else. That anything else may be a constant, a scheme +; variable, or a complex term that may even include logical variables +; such as _ -- but not logical variables defined in the same head-let +; pattern. To make the task of distinguishing logical identifiers +; from anything else easier, we require that anything else of a sort +; of a manifest constant be explicitly quoted or quasiquoted. It would +; be OK to add `, to each 'anything else' term. +; +; Examples: +; (relation-head-let (x y z) (foo x y z)) +; Here x y and z are logical variables. +; (relation-head-let (x y '7) (foo x y)) +; Here we used a manifest constant that must be quoted +; (relation-head-let (x y `(1 2 . ,_)) (foo x y)) +; We used a quasi-quoted constant with an anonymous variable. +; (let ((z `(1 2 . ,_))) (relation-head-let (x y `,z) (foo x y)) +; The same as above, but using a lexical Scheme variable. +; The binding procedure is justified by Proposition 9 of +; the Properties of Substitutions. +; +; 'head-let' is an example of "compile-time" simplifications. +; For example, we distinguish constants in the term head at +; "compile time" and so we re-arrange the argument-passing +; unifications to handle the constants first. +; The test for the anonymous variable (eq? gvv0 _) below +; is an example of a global simplification with a run-time +; test. A compiler could have inferred the result of the test -- but only +; upon the global analysis of all the clauses. +; Replacing a logical variable with an ordinary variable, which does +; not have to be pruned, is equivalent to the use of temporary and +; unsafe variables in WAM. + +(define-syntax relation-head-let + (syntax-rules () + ((_ (head-term ...) . gls) + (relation-head-let "g" () (head-term ...) (head-term ...) . gls)) + ; generate names of formal parameters + ((_ "g" (genvar ...) ((head-term . tail-term) . ht-rest) + head-terms . gls) + (relation-head-let "g" (genvar ... g) ht-rest head-terms . gls)) + ((_ "g" (genvar ...) (head-term . ht-rest) head-terms . gls) + (relation-head-let "g" (genvar ... head-term) ht-rest head-terms . gls)) + ((_ "g" genvars () head-terms . gls) + (relation-head-let "d" () () genvars head-terms genvars . gls)) + ; partition head-terms into vars and others + ((_ "d" vars others (gv . gv-rest) ((hth . htt) . ht-rest) gvs . gls) + (relation-head-let "d" vars ((gv (hth . htt)) . others) + gv-rest ht-rest gvs . gls)) + ((_ "d" vars others (gv . gv-rest) (htv . ht-rest) gvs . gls) + (relation-head-let "d" (htv . vars) others + gv-rest ht-rest gvs . gls)) + ((_ "d" vars others () () gvs . gls) + (relation-head-let "f" vars others gvs . gls)) + + ; final generation + ((_ "f" vars ((gv term) ...) gvs) ; no body + (lambda gvs ; don't bother bind vars + (lambda@ (subst) + (let*-and sfail ((subst (unify gv term subst)) ...) + (at@ succeed subst))))) + + ((_ "f" (var0 ...) ((gvo term) ...) gvs gl) + (lambda gvs + (lambda@ (subst) ; first unify the constants + (let*-and sfail ((subst (unify gvo term subst)) ...) + (let ((var0 (if (eq? var0 __) (logical-variable '?) var0)) ...) + (at@ gl subst)))))))) + +; (define-syntax relation/cut +; (syntax-rules (to-show) +; ((_ cut-id (ex-id ...) (to-show x ...) gl ...) +; (relation/cut cut-id (ex-id ...) () (x ...) (x ...) gl ...)) +; ((_ cut-id ex-ids (var ...) (x0 x1 ...) xs gl ...) +; (relation/cut cut-id ex-ids (var ... g) (x1 ...) xs gl ...)) +; ((_ cut-id (ex-id ...) (g ...) () (x ...) gl ...) +; (lambda (g ...) +; (_exists (ex-id ...) +; (all! (== g x) ... +; (lambda@ (sk fk subst cutk) +; (let ((cut-id (!! cutk))) +; (at@ (all gl ...) sk fk subst cutk))))))))) + +(define-syntax fact + (syntax-rules () + ((_ (ex-id ...) term ...) + (relation (ex-id ...) (to-show term ...) succeed)))) + +; Lifting from goals to relations +; (define-rel-lifted-comb rel-syntax gl-proc-or-syntax) +; Given (gl-proc-or-syntax gl ...) +; define +; (rel-syntax (id ...) rel-exp ...) +; We should make rel-syntax behave as a CBV function, that is, +; evaluate rel-exp early. +; Otherwise, things like +; (define father (extend-relation father ...)) +; loop. + +; (define-syntax extend-relation +; (syntax-rules () +; ((_ (id ...) rel-exp ...) +; (extend-relation-aux (id ...) () rel-exp ...)))) + +; (define-syntax extend-relation-aux +; (syntax-rules () +; ((_ (id ...) ((g rel-exp) ...)) +; (let ((g rel-exp) ...) +; (lambda (id ...) +; (any (g id ...) ...)))) +; ((_ (id ...) (let-pair ...) rel-exp0 rel-exp1 ...) +; (extend-relation-aux (id ...) +; (let-pair ... (g rel-exp0)) rel-exp1 ...)))) + +(define-syntax define-rel-lifted-comb + (syntax-rules () + ((_ rel-syntax-name gl-proc-or-syntax) + (define-syntax rel-syntax-name + (syntax-rules () + ((_ ids . rel-exps) + (lift-gl-to-rel-aux gl-proc-or-syntax ids () . rel-exps))))))) + +(define-syntax lift-gl-to-rel-aux + (syntax-rules () + ((_ gl-handler ids ((g rel-var) ...)) + (let ((g rel-var) ...) + (lambda ids + (gl-handler (g . ids) ...)))) + ((_ gl-handler ids (let-pair ...) rel-exp0 rel-exp1 ...) + (lift-gl-to-rel-aux gl-handler ids + (let-pair ... (g rel-exp0)) rel-exp1 ...)))) + +(define-rel-lifted-comb extend-relation any) + +; The following goal-to-relations +; transformers are roughly equivalent. I don't know which is better. +; see examples below. + +; (lift-to-relations ids (gl-comb rel rel ...)) +(define-syntax lift-to-relations + (syntax-rules () + ((_ ids (gl-comb rel ...)) + (lift-gl-to-rel-aux gl-comb ids () rel ...)))) + +; (let-gls ids ((name rel) ...) body) +; NB: some macro systems do not like if 'ids' below is replaced by (id ...) +(define-syntax let-gls + (syntax-rules () + ((_ ids ((gl-name rel-exp) ...) body) + (lambda ids + (let ((gl-name (rel-exp . ids)) ...) + body))))) + +; Unify lifted to be a binary relation +(define-syntax == + (syntax-rules (__) + ((_ __ u) (lambda@ (subst sk) (at@ sk subst))) + ((_ t __) (lambda@ (subst sk) (at@ sk subst))) + ((_ t u) + (lambda@ (subst) + (let*-and sfail ((subst (unify t u subst))) + (succeed subst)))))) + + +; query (redo-k subst id ...) A SE ... -> result or '() +; The macro 'query' runs the goal A in the empty +; initial substitution, and reifies the resulting +; answer: the substitution and the redo-continuation bound +; to fresh variables with the names supplied by the user. +; The substitution and the redo continuation can then be used +; by Scheme expressions SE ... +; Before running the goal, the macro creates logical variables +; id ... for use in A and SE ... +; If the goal fails, '() is returned and SE ... are not evaluated. +; Note the similarity with shift/reset-based programming +; where the immediate return signifies "failure" and the invocation +; of the continuation a "success" +; Returning '() on failure makes it easy to create the list of answers + +(define-syntax query + (syntax-rules () + ((_ (redo-k subst id ...) A SE ...) + (let-lv (id ...) + (at@ A empty-subst + (lambda@ (subst redo-k) SE ...) + (lambda () '())))))) + +(define stream-prefix + (lambda (n strm) + (if (null? strm) '() + (cons (car strm) + (if (zero? n) '() + (stream-prefix (- n 1) ((cdr strm)))))))) + +(define-syntax solve + (syntax-rules () + ((_ n (var0 ...) gl) + (if (<= n 0) '() + (stream-prefix (- n 1) + (query (redo-k subst var0 ...) + gl + (cons (reify-subst (list var0 ...) subst) redo-k))))))) + + +(define-syntax solution + (syntax-rules () + ((_ (var0 ...) x) + (let ((ls (solve 1 (var0 ...) x))) + (if (null? ls) #f (car ls)))))) + + +(define-syntax project + (syntax-rules () + ((_ (var ...) gl) + (lambda@ (subst) + (let ((var (nonvar! (subst-in var subst))) ...) + (at@ gl subst)))))) + +(define-syntax project/no-check + (syntax-rules () + ((_ (var ...) gl) + (lambda@ (subst) + (let ((var (subst-in var subst)) ...) + (at@ gl subst)))))) + +(define-syntax predicate + (syntax-rules () + ((_ scheme-expression) + (lambda@ (subst) + (if scheme-expression (succeed subst) (fail subst)))))) + +(define nonvar! + (lambda (t) + (if (var? t) + (errorf 'nonvar! "Logic variable ~s found after substituting." + (reify t)) + t))) + +; TRACE-VARS TITLE (VAR ...) +; Is a deterministic goal that prints the current values of VARS +; TITLE is any displayable thing. + +; (define-syntax trace-vars +; (syntax-rules () +; ((trace-vars title (var0 ...)) +; (promise-one-answer +; (predicate/no-check (var0 ...) +; (begin (display title) (display " ") +; (display '(var0 ...)) (display " ") (display (list var0 ...)) +; (newline))))))) + +(define-syntax trace-vars + (syntax-rules () + ((_ title (var0 ...)) + (promise-one-answer + (project/no-check (var0 ...) + (predicate + (for-each + (lambda (name val) + (cout title " " name ": " val nl)) + '(var0 ...) (reify `(,var0 ...))) + )))))) + +;equality predicate: X == Y in Prolog +;if X is a var, then X == Y holds only if Y +;is the same var +(define *equal? + (lambda (x y) + (cond + ((and (var? x) (var? y)) (eq? x y)) + ((var? x) #f) ; y is not a var + ((var? y) #f) ; x is not a var + (else (equal? x y))))) + +; extend-relation-with-recur-limit LIMIT VARS RELS -> REL +; This is a variation of 'extend-relation' that makes sure +; that the extended relation is not recursively entered more +; than LIMIT times. The form extend-relation-with-recur-limit +; can be used to cut a left-recursive relation, and to implement +; an iterative deepening strategy. +; extend-relation-with-recur-limit must be a special form +; because we need to define the depth-counter-var +; outside of relations' lambda (so we count the recursive invocations +; for all arguments). +(define-syntax extend-relation-with-recur-limit + (syntax-rules () + ((_ limit ids rel ...) + (let ((depth-counter-var (logical-variable '*depth-counter*))) + (lambda ids + (let ((gl (any (rel . ids) ...))) + (lambda@ (subst) + (cond + ((assq depth-counter-var subst) + => (lambda (cmt) + (let ((counter (commitment->term cmt))) + (if (>= counter limit) + sfail + (let ((s (extend-subst depth-counter-var + (+ counter 1) subst))) + (at@ gl s)))))) + (else + (let ((s (extend-subst depth-counter-var 1 subst))) + (at@ gl s))))))))) + )) + +; ?- help(call_with_depth_limit/3). +; call_with_depth_limit(+Goal, +Limit, -Result) +; If Goal can be proven without recursion deeper than Limit levels, +; call_with_depth_limit/3 succeeds, binding Result to the deepest +; recursion level used during the proof. Otherwise, Result is +; unified with depth_limit_exceeded if the limit was exceeded during +; the proof, or the entire predicate fails if Goal fails without +; exceeding Limit. + +; The depth-limit is guarded by the internal machinery. This may +; differ from the depth computed based on a theoretical model. For +; example, true/0 is translated into an inlined virtual machine +; instruction. Also, repeat/0 is not implemented as below, but as a +; non-deterministic foreign predicate. + +; repeat. +; repeat :- +; repeat. + +; As a result, call_with_depth_limit/3 may still loop inifitly on +; programs that should theoretically finish in finite time. This +; problem can be cured by using Prolog equivalents to such built-in +; predicates. + +; This predicate may be used for theorem-provers to realise +; techniques like iterrative deepening. It was implemented after +; discussion with Steve Moyle smoyle@ermine.ox.ac.uk. + +;------------------------------------------------------------------------ +;;;;; Starts the real work of the system. + +(define-rel-lifted-comb intersect-relation all) + +(define (kanren-tests) + (let* ((father + (relation () + (to-show 'jon 'sam))) + (child-of-male + (relation (child dad) + (to-show child dad) + (father dad child))) + (child-of-male1 + (relation (child dad) + (to-show child dad) + (child-of-male dad child))) + ) + (test-check 'test-father0 + (let ((result + (at@ (father 'jon 'sam) empty-subst + initial-sk initial-fk))) + (and + (equal? (car result) '()) + (equal? ((cdr result)) '()))) + #t) + + (test-check 'test-child-of-male-0 + (reify-subst '() + (car (at@ (child-of-male 'sam 'jon) empty-subst + initial-sk initial-fk))) + ;`(,(commitment 'child.0 'sam) ,(commitment 'dad.0 'jon))) + '()) ; variables shouldn't leak + + + ; The mark should be found here... + (test-check 'test-child-of-male-1 + (reify-subst '() + (car (at@ (child-of-male 'sam 'jon) empty-subst + initial-sk initial-fk))) + ;`(,(commitment 'child.0 'sam) ,(commitment 'dad.0 'jon))) + '()) + ) + + (let* ((father + (relation () + (to-show 'jon 'sam))) + (rob/sal + (relation () + (to-show 'rob 'sal))) + (new-father + (extend-relation (a1 a2) father rob/sal)) + (rob/pat + (relation () + (to-show 'rob 'pat))) + (newer-father + (extend-relation (a1 a2) new-father rob/pat)) + + ) + (test-check 'test-father-1 + (let ((result + (at@ (new-father 'rob 'sal) empty-subst + initial-sk initial-fk))) + (and + (equal? (car result) '()) + (equal? ((cdr result)) '()))) + #t) + + (test-check 'test-father-2 + (query (redo-k subst x) + (new-father 'rob x) + (list (equal? (car subst) (commitment x 'sal)) (redo-k))) + '(#t ())) + + (test-check 'test-father-3 + (query (_ subst x) + (new-father 'rob x) + (reify-subst (list x) subst)) + '((x.0 sal))) + + (test-check 'test-father-4 + (query (_ subst x y) + (new-father x y) + (reify-subst (list x y) subst)) + '((x.0 jon) (y.0 sam))) + + (test-check 'test-father-5 + (query (redok subst x) + (newer-father 'rob x) + (_pretty-print subst) + (cons + (reify-subst (list x) subst) + (redok))) + '(((x.0 sal)) ((x.0 pat)))) + + ) + + (let* ((father + (extend-relation (a1 a2) + (relation () (to-show 'jon 'sam)) + (relation () (to-show 'rob 'sal)) + (relation () (to-show 'rob 'pat)) + (relation () (to-show 'sam 'rob))) + )) + + (test-check 'test-father-6/solve + (and + (equal? + (solve 5 (x) (father 'rob x)) + '(((x.0 sal)) ((x.0 pat)))) + (equal? + (solve 6 (x y) (father x y)) + '(((x.0 jon) (y.0 sam)) + ((x.0 rob) (y.0 sal)) + ((x.0 rob) (y.0 pat)) + ((x.0 sam) (y.0 rob))))) + #t) + + (test-check 'test-father-7/solution + (solution (x) (father 'rob x)) + '((x.0 sal))) + ) + + + + ; (define-syntax intersect-relation + ; (syntax-rules () + ; ((_ (id ...) rel-exp) rel-exp) + ; ((_ (id ...) rel-exp0 rel-exp1 rel-exp2 ...) + ; (binary-intersect-relation (id ...) rel-exp0 + ; (intersect-relation (id ...) rel-exp1 rel-exp2 ...))))) + + (let* + ((parents-of-scouts + (extend-relation (a1 a2) + (fact () 'sam 'rob) + (fact () 'roz 'sue) + (fact () 'rob 'sal))) + (parents-of-athletes + (extend-relation (a1 a2) + (fact () 'sam 'roz) + (fact () 'roz 'sue) + (fact () 'rob 'sal))) + + (busy-parents + (intersect-relation (a1 a2) parents-of-scouts parents-of-athletes)) + + (conscientious-parents + (extend-relation (a1 a2) parents-of-scouts parents-of-athletes)) + ) + + (test-check 'test-conscientious-parents + (solve 7 (x y) (conscientious-parents x y)) + '(((x.0 sam) (y.0 rob)) + ((x.0 roz) (y.0 sue)) + ((x.0 rob) (y.0 sal)) + ((x.0 sam) (y.0 roz)) + ((x.0 roz) (y.0 sue)) + ((x.0 rob) (y.0 sal)))) + ) + + (let* ((father + (extend-relation (a1 a2) + (relation () (to-show 'jon 'sam)) + (relation () (to-show 'rob 'sal)) + (relation () (to-show 'rob 'pat)) + (relation () (to-show 'sam 'rob))) + )) + + (let + ((grandpa-sam + (relation (grandchild) + (to-show grandchild) + (_exists (parent) + (all (father 'sam parent) + (father parent grandchild)))))) + (test-check 'test-grandpa-sam-1 + (solve 6 (y) (grandpa-sam y)) + '(((y.0 sal)) ((y.0 pat)))) + ) + + (let + ((grandpa-sam + (relation ((once grandchild)) + (to-show grandchild) + (_exists (parent) + (all (father 'sam parent) + (father parent grandchild)))))) + (test-check 'test-grandpa-sam-1 + (solve 6 (y) (grandpa-sam y)) + '(((y.0 sal)) ((y.0 pat)))) + ) + + (let ((child + (relation ((once child) (once dad)) + (to-show child dad) + (father dad child)))) + (test-check 'test-child-1 + (solve 10 (x y) (child x y)) + '(((x.0 sam) (y.0 jon)) + ((x.0 sal) (y.0 rob)) + ((x.0 pat) (y.0 rob)) + ((x.0 rob) (y.0 sam)))) + ) + + (let ((grandpa + (relation ((once grandad) (once grandchild)) + (to-show grandad grandchild) + (_exists (parent) + (all + (father grandad parent) + (father parent grandchild)))))) + (test-check 'test-grandpa-1 + (solve 4 (x) (grandpa 'sam x)) + '(((x.0 sal)) ((x.0 pat))))) + + (let ((grandpa-maker + (lambda (guide* grandad*) + (relation (grandchild) + (to-show grandchild) + (_exists (parent) + (all + (guide* grandad* parent) + (guide* parent grandchild))))))) + (test-check 'test-grandpa-maker-2 + (solve 4 (x) ((grandpa-maker father 'sam) x)) + '(((x.0 sal)) ((x.0 pat))))) + + ) + + (let* + ((father + (extend-relation (a1 a2) + (fact () 'jon 'sam) + (extend-relation (a1 a2) + (fact () 'sam 'rob) + (extend-relation (a1 a2) + (fact () 'sam 'roz) + (extend-relation (a1 a2) + (fact () 'rob 'sal) + (fact () 'rob 'pat)))))) + (mother + (extend-relation (a1 a2) + (fact () 'roz 'sue) + (fact () 'roz 'sid))) + ) + + (let* + ((grandpa/father + (relation (grandad grandchild) + (to-show grandad grandchild) + (_exists (parent) + (all + (father grandad parent) + (father parent grandchild))))) + (grandpa/mother + (relation (grandad grandchild) + (to-show grandad grandchild) + (_exists (parent) + (all + (father grandad parent) + (mother parent grandchild))))) + (grandpa + (extend-relation (a1 a2) grandpa/father grandpa/mother))) + + (test-check 'test-grandpa-5 + (solve 10 (y) (grandpa 'sam y)) + '(((y.0 sal)) ((y.0 pat)) ((y.0 sue)) ((y.0 sid)))) + ) + + ; A relation is just a function + (let + ((grandpa-sam + (let ((r (relation (child) + (to-show child) + (_exists (parent) + (all + (father 'sam parent) + (father parent child)))))) + (relation (child) + (to-show child) + (r child))))) + + (test-check 'test-grandpa-55 + (solve 6 (y) (grandpa-sam y)) + '(((y.0 sal)) ((y.0 pat)))) + ) + + ; The solution that used cuts + ; (define grandpa/father + ; (relation/cut cut (grandad grandchild) + ; (to-show grandad grandchild) + ; (_exists (parent) + ; (all + ; (father grandad parent) + ; (father parent grandchild) + ; cut)))) + ; + ; (define grandpa/mother + ; (relation (grandad grandchild) + ; (to-show grandad grandchild) + ; (_exists (parent) + ; (all + ; (father grandad parent) + ; (mother parent grandchild))))) + + + ; Now we don't need it + (let* + ((grandpa/father + (relation (grandad grandchild) + (to-show grandad grandchild) + (_exists (parent) + (all! + (father grandad parent) + (father parent grandchild))))) + + (grandpa/mother + (relation (grandad grandchild) + (to-show grandad grandchild) + (_exists (parent) + (all + (father grandad parent) + (mother parent grandchild))))) + + (grandpa + (lift-to-relations (a1 a2) + (all! + (extend-relation (a1 a2) grandpa/father grandpa/mother)))) + ) + (test-check 'test-grandpa-8 + (solve 10 (x y) (grandpa x y)) + '(((x.0 jon) (y.0 rob)))) + ) + + ; The solution that used to require cuts + ; (define grandpa/father + ; (relation/cut cut (grandad grandchild) + ; (to-show grandad grandchild) + ; (_exists (parent) + ; (all cut (father grandad parent) (father parent grandchild))))) + + (let + ((grandpa/father + (relation (grandad grandchild) + (to-show grandad grandchild) + (_exists (parent) + (all + (father grandad parent) (father parent grandchild))))) + + (grandpa/mother + (relation (grandad grandchild) + (to-show grandad grandchild) + (_exists (parent) + (all + (father grandad parent) (mother parent grandchild))))) + ) + + ; Properly, this requires soft cuts, aka *->, or Mercury's + ; if-then-else. But we emulate it... + (let + ((grandpa + (let-gls (a1 a2) ((grandpa/father grandpa/father) + (grandpa/mother grandpa/mother)) + (if-only (succeeds grandpa/father) grandpa/father grandpa/mother))) + ) + (test-check 'test-grandpa-10 + (solve 10 (x y) (grandpa x y)) + '(((x.0 jon) (y.0 rob)) + ((x.0 jon) (y.0 roz)) + ((x.0 sam) (y.0 sal)) + ((x.0 sam) (y.0 pat)))) + (test-check 'test-grandpa-10-1 + (solve 10 (x) (grandpa x 'sue)) + '(((x.0 sam)))) + ) + + ; The same as above, with if-all! -- just to test the latter. + (let + ((grandpa + (let-gls (a1 a2) ((grandpa/father grandpa/father) + (grandpa/mother grandpa/mother)) + (if-only (all! (succeeds grandpa/father) (succeeds grandpa/father)) + grandpa/father grandpa/mother)))) + + (test-check 'test-grandpa-10 + (solve 10 (x y) (grandpa x y)) + '(((x.0 jon) (y.0 rob)) + ((x.0 jon) (y.0 roz)) + ((x.0 sam) (y.0 sal)) + ((x.0 sam) (y.0 pat)))) + + (test-check 'test-grandpa-10-1 + (solve 10 (x) (grandpa x 'sue)) + '(((x.0 sam)))) + ) + + + ; Now do it with soft-cuts + (let + ((grandpa + (let-gls (a1 a2) ((grandpa/father grandpa/father) + (grandpa/mother grandpa/mother)) + (if-some grandpa/father succeed grandpa/mother))) + ) + (test-check 'test-grandpa-10-soft-cut + (solve 10 (x y) (grandpa x y)) + '(((x.0 jon) (y.0 rob)) + ((x.0 jon) (y.0 roz)) + ((x.0 sam) (y.0 sal)) + ((x.0 sam) (y.0 pat)))) + ) + + (let* + ((a-grandma + (relation (grandad grandchild) + (to-show grandad grandchild) + (_exists (parent) + (all! (mother grandad parent))))) + (no-grandma-grandpa + (let-gls (a1 a2) ((a-grandma a-grandma) + (grandpa (lift-to-relations (a1 a2) + (all! + (extend-relation (a1 a2) + grandpa/father grandpa/mother))))) + (if-only a-grandma fail grandpa))) + ) + (test-check 'test-no-grandma-grandpa-1 + (solve 10 (x) (no-grandma-grandpa 'roz x)) + '())) + )) + + (let + ((parents-of-scouts + (extend-relation (a1 a2) + (fact () 'sam 'rob) + (fact () 'roz 'sue) + (fact () 'rob 'sal))) + (fathers-of-cubscouts + (extend-relation (a1 a2) + (fact () 'sam 'bob) + (fact () 'tom 'adam) + (fact () 'tad 'carl))) + ) + + (test-check 'test-partially-eval-sgl + (let-lv (p1 p2) + (let* ((parents-of-scouts-sgl + ((parents-of-scouts p1 p2) empty-subst)) + (cons@ (lambda@ (x y) (cons x y))) + (split1 (at@ + partially-eval-sgl parents-of-scouts-sgl + cons@ (lambda () '()))) + (a1 (car split1)) + (split2 (at@ partially-eval-sgl (cdr split1) cons@ + (lambda () '()))) + (a2 (car split2)) + (split3 (at@ partially-eval-sgl (cdr split2) cons@ + (lambda () '()))) + (a3 (car split3))) + (map (lambda (subst) + (reify-subst (list p1 p2) subst)) + (list a1 a2 a3)))) + '(((p1.0 sam) (p2.0 rob)) ((p1.0 roz) (p2.0 sue)) ((p1.0 rob) (p2.0 sal)))) + ) + + + (test-check 'test-pred1 + (let ((test1 + (lambda (x) + (any (predicate (< 4 5)) + (== x (< 6 7)))))) + (solution (x) (test1 x))) + '((x.0 _.0))) + + (test-check 'test-pred2 + (let ((test2 + (lambda (x) + (any (predicate (< 5 4)) + (== x (< 6 7)))))) + (solution (x) (test2 x))) + '((x.0 #t))) + + (test-check 'test-pred3 + (let ((test3 + (lambda (x y) + (any + (== x (< 5 4)) + (== y (< 6 7)))))) + (solution (x y) (test3 x y))) + `((x.0 #f) (y.0 _.0))) + + (test-check 'test-Seres-Spivey + (let ((father + (lambda (dad child) + (any + (all (== dad 'jon) (== child 'sam)) + (all (== dad 'sam) (== child 'rob)) + (all (== dad 'sam) (== child 'roz)) + (all (== dad 'rob) (== child 'sal)) + (all (== dad 'rob) (== child 'pat)) + (all (== dad 'jon) (== child 'hal)) + (all (== dad 'hal) (== child 'ted)) + (all (== dad 'sam) (== child 'jay)))))) + (letrec + ((ancestor + (lambda (old young) + (any + (father old young) + (_exists (not-so-old) + (all + (father old not-so-old) + (ancestor not-so-old young))))))) + (solve 20 (x) (ancestor 'jon x)))) + '(((x.0 sam)) + ((x.0 hal)) + ((x.0 rob)) + ((x.0 roz)) + ((x.0 jay)) + ((x.0 sal)) + ((x.0 pat)) + ((x.0 ted)))) + + (let () + (define towers-of-hanoi + (letrec + ((move + (extend-relation (a1 a2 a3 a4) + (fact () 0 __ __ __) + (relation (n a b c) + (to-show n a b c) + (project (n) + (if-only (predicate (positive? n)) + (let ((m (- n 1))) + (all + (move m a c b) + (project (a b) + (begin + (cout "Move a disk from " a " to " b nl) + (move m c b a))))))))))) + (relation (n) + (to-show n) + (move n 'left 'middle 'right)))) + + (cout "test-towers-of-hanoi with 3 disks: " + (solution () (towers-of-hanoi 3)) + nl nl + )) + + + (test-check 'test-fun-resubst + (reify + (let ((j (relation (x w z) + (to-show z) + (let ((x 4) + (w 3)) + (== z (cons x w)))))) + (solve 4 (q) (j q)))) + '(((q.0 (4 . 3))))) + + (let () + (define towers-of-hanoi-path + (let ((steps '())) + (let ((push-step (lambda (x y) (set! steps (cons `(,x ,y) steps))))) + (letrec + ((move + (extend-relation (a1 a2 a3 a4) + (fact () 0 __ __ __) + (relation (n a b c) + (to-show n a b c) + (project (n) + (if-only (predicate (positive? n)) + (let ((m (- n 1))) + (all + (move m a c b) + (project (a b) + (begin + (push-step a b) + (move m c b a))))))))))) + (relation (n path) + (to-show n path) + (begin + (set! steps '()) + (any + (fails (move n 'l 'm 'r)) + (== path (reverse steps))))))))) + + (test-check 'test-towers-of-hanoi-path + (solution (path) (towers-of-hanoi-path 3 path)) + '((path.0 ((l m) (l r) (m r) (l m) (r l) (r m) (l m)))))) + + ;------------------------------------------------------------------------ + + + (test-check 'unification-of-free-vars-1 + (solve 1 (x) + (let-lv (y) + (all!! (== x y) (== y 5)))) + '(((x.0 5)))) + + (test-check 'unification-of-free-vars-2 + (solve 1 (x) + (let-lv (y) + (all!! (== y 5) (== x y)))) + '(((x.0 5)))) + + (test-check 'unification-of-free-vars-3 + (solve 1 (x) + (let-lv (y) + (all!! (== y x) (== y 5)))) + '(((x.0 5)))) + + (test-check 'unification-of-free-vars-3 + (solve 1 (x) + (let-lv (y) + (all!! (== x y) (== y 5) (== x y)))) + '(((x.0 5)))) + + (test-check 'unification-of-free-vars-4 + (solve 1 (x) + (_exists (y) + (all! (== y x) (== y 5) (== x y)))) + '(((x.0 5)))) + + + (letrec + ((concat + (lambda (xs ys) + (cond + ((null? xs) ys) + (else (cons (car xs) (concat (cdr xs) ys))))))) + + (test-check 'test-concat-as-function + (concat '(a b c) '(u v)) + '(a b c u v)) + + (test-check 'test-fun-concat + (solve 1 (q) + (== q (concat '(a b c) '(u v)))) + '(((q.0 (a b c u v))))) + ) + + ; Now the same with the relation + (letrec + ((concat + (extend-relation (a1 a2 a3) + (fact (xs) '() xs xs) + (relation (x xs (once ys) zs) + (to-show `(,x . ,xs) ys `(,x . ,zs)) + (concat xs ys zs))))) + (test-check 'test-concat + (values + (and + (equal? + (solve 6 (q) (concat '(a b c) '(u v) q)) + '(((q.0 (a b c u v))))) + (equal? + (solve 6 (q) (concat '(a b c) q '(a b c u v))) + '(((q.0 (u v))))) + (equal? + (solve 6 (q) (concat q '(u v) '(a b c u v))) + '(((q.0 (a b c))))) + (equal? + (solve 6 (q r) (concat q r '(a b c u v))) + '(((q.0 ()) (r.0 (a b c u v))) + ((q.0 (a)) (r.0 (b c u v))) + ((q.0 (a b)) (r.0 (c u v))) + ((q.0 (a b c)) (r.0 (u v))) + ((q.0 (a b c u)) (r.0 (v))) + ((q.0 (a b c u v)) (r.0 ())))) + (equal? + (solve 6 (q r s) (concat q r s)) + '(((q.0 ()) (r.0 _.0) (s.0 _.0)) + ((q.0 (_.0)) (r.0 _.1) (s.0 (_.0 . _.1))) + ((q.0 (_.0 _.1)) (r.0 _.2) (s.0 (_.0 _.1 . _.2))) + ((q.0 (_.0 _.1 _.2)) (r.0 _.3) (s.0 (_.0 _.1 _.2 . _.3))) + ((q.0 (_.0 _.1 _.2 _.3)) (r.0 _.4) (s.0 (_.0 _.1 _.2 _.3 . _.4))) + ((q.0 (_.0 _.1 _.2 _.3 _.4)) (r.0 _.5) + (s.0 (_.0 _.1 _.2 _.3 _.4 . _.5)))) + ) + '(equal? + (solve 6 (q r) (concat q '(u v) `(a b c . ,r))) + '(((q.0 (a b c)) (r.0 (u v))) + ((q.0 (a b c _.0)) (r.0 (_.0 u v))) + ((q.0 (a b c _.0 _.1)) (r.0 (_.0 _.1 u v))) + ((q.0 (a b c _.0 _.1 _.2)) (r.0 (_.0 _.1 _.2 u v))) + ((q.0 (a b c _.0 _.1 _.2 _.3)) (r.0 (_.0 _.1 _.2 _.3 u v))) + ((q.0 (a b c _.0 _.1 _.2 _.3 _.4)) + (r.0 (_.0 _.1 _.2 _.3 _.4 u v))))) + (equal? + (solve 6 (q) (concat q '() q)) + '(((q.0 ())) + ((q.0 (_.0))) + ((q.0 (_.0 _.1))) + ((q.0 (_.0 _.1 _.2))) + ((q.0 (_.0 _.1 _.2 _.3))) + ((q.0 (_.0 _.1 _.2 _.3 _.4))))) + )) + #t) + ) + + ; Using the properties of the unifier to do the proper garbage + ; collection of logical vars + + ; (test-check 'lv-elim-1 + ; (reify + ; (let-lv (x z dummy) + ; (at@ + ; (_exists (y) + ; (== `(,x ,z ,y) `(5 9 ,x))) + ; (lambda@ (fk subst) subst) + ; initial-fk + ; (unit-subst dummy 'dummy)))) + ; '((y.0 . 5) (z.0 . 9) (x.0 . 5) (dummy.0 . dummy))) + ; ;'((z.0 . 9) (x.0 . 5) (dummy.0 . dummy))) + + ; (test-check 'lv-elim-2 + ; (reify + ; (let-lv (x dummy) + ; (at@ + ; (_exists (y) + ; (== `(,x ,y) `((5 ,y) ,7))) + ; (lambda@ (fk subst) subst) + ; initial-fk + ; (unit-subst dummy 'dummy)))) + ; '((y.0 . 7) (x.0 5 y.0) (dummy.0 . dummy))) + ; ;'((a*.0 . 7) (x.0 5 a*.0) (dummy.0 . dummy))) + + ; ; verifying corollary 2 of proposition 10 + ; (test-check 'lv-elim-3 + ; (reify + ; (let-lv (x v dummy) + ; (at@ + ; (_exists (y) + ; (== x `(a b c ,v d))) + ; (lambda@ (fk subst) subst) + ; initial-fk + ; (unit-subst dummy 'dummy)))) + ; '((x.0 a b c v.0 d) (dummy.0 . dummy))) + ; ;'((a*.0 . v.0) (x.0 a b c a*.0 d) (dummy.0 . dummy))) + + ; ; pruning several variables sequentially and in parallel + ; (test-check 'lv-elim-4-1 + ; (reify + ; (let-lv (x v b dummy) + ; (at@ + ; (let-lv (y) + ; (== `(,b ,x ,y) `(,x ,y 1))) + ; (lambda@ (fk subst) subst) + ; initial-fk + ; (unit-subst dummy 'dummy)))) + ; '((y.0 . 1) (x.0 . y.0) (b.0 . x.0) (dummy.0 . dummy))) + + ; ; (test-check 'lv-elim-4-2 + ; ; (concretize + ; ; (let-lv (v b dummy) + ; ; (at@ + ; ; (_exists (x) + ; ; (_exists (y) + ; ; (== `(,b ,x ,y) `(,x ,y 1)))) + ; ; (lambda@ (fk subst) subst) + ; ; initial-fk + ; ; (unit-subst dummy 'dummy)))) + ; ; '((b.0 . 1) (dummy.0 . dummy))) + + ; ; (test-check 'lv-elim-4-3 + ; ; (concretize + ; ; (let-lv (v b dummy) + ; ; (at@ + ; ; (_exists (y) + ; ; (_exists (x) + ; ; (== `(,b ,x ,y) `(,x ,y 1)))) + ; ; (lambda@ (fk subst) subst) + ; ; initial-fk + ; ; (unit-subst dummy 'dummy)))) + ; ; '((b.0 . 1) (dummy.0 . dummy))) + + ; (test-check 'lv-elim-4-4 + ; (reify + ; (let-lv (v b dummy) + ; (at@ + ; (_exists (x y) + ; (== `(,b ,x ,y) `(,x ,y 1))) + ; (lambda@ (fk subst) subst) + ; initial-fk + ; (unit-subst dummy 'dummy)))) + ; '((y.0 . 1) (x.0 . y.0) (b.0 . x.0) (dummy.0 . dummy))) + ; ;'((b.0 . 1) (dummy.0 . dummy))) + + ; ; pruning several variables sequentially and in parallel + ; ; for indirect (cyclic) dependency + ; (test-check 'lv-elim-5-1 + ; (reify + ; (let-lv (x v b dummy) + ; (at@ + ; (let-lv (y) + ; (== `(,b ,y ,x) `(,x (1 ,x) ,y))) + ; (lambda@ (fk subst) subst) + ; initial-fk + ; (unit-subst dummy 'dummy)))) + ; '((x.0 1 x.0) (y.0 1 x.0) (b.0 . x.0) (dummy.0 . dummy))) + ; ;'((x.0 1 a*.0) (a*.0 . x.0) (y.0 1 a*.0) (b.0 . x.0) (dummy.0 . dummy))) + + ; ; (test-check 'lv-elim-5-2 + ; ; (concretize + ; ; (let-lv (v b dummy) + ; ; (at@ + ; ; (_exists (x) + ; ; (_exists (y) + ; ; (== `(,b ,y ,x) `(,x (1 ,x) ,y)))) + ; ; (lambda@ (fk subst) subst) + ; ; initial-fk + ; ; (unit-subst dummy 'dummy)))) + ; ; '((a*.0 1 a*.0) (b.0 1 a*.0) (dummy.0 . dummy))) + + ; ; (test-check 'lv-elim-5-3 + ; ; (concretize + ; ; (let-lv (v b dummy) + ; ; (at@ + ; ; (_exists (y) + ; ; (_exists (x) + ; ; (== `(,b ,y ,x) `(,x (1 ,x) ,y)))) + ; ; (lambda@ (fk subst) subst) + ; ; initial-fk + ; ; (unit-subst dummy 'dummy)))) + ; ; '((a*.0 1 a*.0) (b.0 1 a*.0) (dummy.0 . dummy))) + + ; (test-check 'lv-elim-5-4 + ; (reify + ; (let-lv (v b dummy) + ; (at@ + ; (_exists (x y) + ; (== `(,b ,y ,x) `(,x (1 ,x) ,y))) + ; (lambda@ (fk subst) subst) + ; initial-fk + ; (unit-subst dummy 'dummy)))) + ; '((x.0 1 x.0) (y.0 1 x.0) (b.0 . x.0) (dummy.0 . dummy))) + ; ;'((a*.0 1 a*.0) (b.0 1 a*.0) (dummy.0 . dummy))) + + ; ; We should only be concerned about a direct dependency: + ; ; ((x . y) (y . (1 t)) (t . x) (a . x)) + ; ; pruning x and y in sequence or in parallel gives the same result: + ; ; ((t . (1 t)) (a . (1 t))) + + + ; Extending relations in truly mathematical sense. + ; First, why do we need this. + (let* + ((fact1 (fact () 'x1 'y1)) + (fact2 (fact () 'x2 'y2)) + (fact3 (fact () 'x3 'y3)) + (fact4 (fact () 'x4 'y4)) + + ; R1 and R2 are overlapping + (R1 (extend-relation (a1 a2) fact1 fact2)) + (R2 (extend-relation (a1 a2) fact1 fact3)) + ) + ; Infinitary relation + ; r(z,z). + ; r(s(X),s(Y)) :- r(X,Y). + (letrec + ((Rinf + (extend-relation (a1 a2) + (fact () 'z 'z) + (relation (x y t1 t2) + (to-show t1 t2) + (all + (== t1 `(s ,x)) + (== t2 `(s ,y)) + (Rinf x y))))) + ) + + (cout nl "R1:" nl) + (_pretty-print (solve 10 (x y) (R1 x y))) + (cout nl "R2:" nl) + (_pretty-print (solve 10 (x y) (R2 x y))) + (cout nl "R1+R2:" nl) + (_pretty-print + (solve 10 (x y) + ((extend-relation (a1 a2) R1 R2) x y))) + + (cout nl "Rinf:" nl) + (values (_pretty-print (solve 5 (x y) (Rinf x y)))) + (cout nl "Rinf+R1: Rinf starves R1:" nl) + (values + (_pretty-print + (solve 5 (x y) + ((extend-relation (a1 a2) Rinf R1) x y)))) + + ; Solving the starvation problem: extend R1 and R2 so that they + ; are interleaved + ; ((sf-extend R1 R2) sk fk) + ; (R1 sk fk) + ; If R1 fails, we try the rest of R2 + ; If R1 succeeds, it executes (sk fk) + ; with fk to re-prove R1. Thus fk is the "rest" of R1 + ; So we pass sk (lambda () (run-rest-of-r2 interleave-with-rest-of-r1)) + ; There is a fixpoint in the following algorithm! + ; Or a second-level shift/reset! + + (test-check "Rinf+R1" + (values + (solve 7 (x y) + (any-interleave (Rinf x y) (R1 x y)))) + '(((x.0 z) (y.0 z)) + ((x.0 x1) (y.0 y1)) + ((x.0 (s z)) (y.0 (s z))) + ((x.0 x2) (y.0 y2)) + ((x.0 (s (s z))) (y.0 (s (s z)))) + ((x.0 (s (s (s z)))) (y.0 (s (s (s z))))) + ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))) + ) + + (test-check "R1+Rinf" + (values + (solve 7 (x y) + (any-interleave (R1 x y) (Rinf x y)))) + '(((x.0 x1) (y.0 y1)) + ((x.0 z) (y.0 z)) + ((x.0 x2) (y.0 y2)) + ((x.0 (s z)) (y.0 (s z))) + ((x.0 (s (s z))) (y.0 (s (s z)))) + ((x.0 (s (s (s z)))) (y.0 (s (s (s z))))) + ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))) + ) + + + (test-check "R2+R1" + (solve 7 (x y) + (any-interleave (R2 x y) (R1 x y))) + '(((x.0 x1) (y.0 y1)) + ((x.0 x1) (y.0 y1)) + ((x.0 x3) (y.0 y3)) + ((x.0 x2) (y.0 y2))) + ) + + (test-check "R1+fact3" + (solve 7 (x y) + (any-interleave (R1 x y) (fact3 x y))) + '(((x.0 x1) (y.0 y1)) ((x.0 x3) (y.0 y3)) ((x.0 x2) (y.0 y2))) + ) + + (test-check "fact3+R1" + (solve 7 (x y) + (any-interleave (fact3 x y) (R1 x y))) + '(((x.0 x3) (y.0 y3)) ((x.0 x1) (y.0 y1)) ((x.0 x2) (y.0 y2))) + ) + + ; testing all-interleave + (test-check 'all-interleave-1 + (solve 100 (x y z) + (all-interleave + (any (== x 1) (== x 2)) + (any (== y 3) (== y 4)) + (any (== z 5) (== z 6) (== z 7)))) + '(((x.0 1) (y.0 3) (z.0 5)) + ((x.0 2) (y.0 3) (z.0 5)) + ((x.0 1) (y.0 4) (z.0 5)) + ((x.0 2) (y.0 4) (z.0 5)) + ((x.0 1) (y.0 3) (z.0 6)) + ((x.0 2) (y.0 3) (z.0 6)) + ((x.0 1) (y.0 4) (z.0 6)) + ((x.0 2) (y.0 4) (z.0 6)) + ((x.0 1) (y.0 3) (z.0 7)) + ((x.0 2) (y.0 3) (z.0 7)) + ((x.0 1) (y.0 4) (z.0 7)) + ((x.0 2) (y.0 4) (z.0 7))) + ) + + (test-check "R1 * Rinf: clearly starvation" + (solve 5 (x y u v) + (all (R1 x y) (Rinf u v))) + ; indeed, only the first choice of R1 is apparent + '(((x.0 x1) (y.0 y1) (u.0 z) (v.0 z)) + ((x.0 x1) (y.0 y1) (u.0 (s z)) (v.0 (s z))) + ((x.0 x1) (y.0 y1) (u.0 (s (s z))) (v.0 (s (s z)))) + ((x.0 x1) (y.0 y1) (u.0 (s (s (s z)))) (v.0 (s (s (s z))))) + ((x.0 x1) (y.0 y1) (u.0 (s (s (s (s z))))) (v.0 (s (s (s (s z))))))) + ) + + (test-check "R1 * Rinf: interleaving" + (solve 5 (x y u v) + (all-interleave (R1 x y) (Rinf u v))) + ; both choices of R1 are apparent + '(((x.0 x1) (y.0 y1) (u.0 z) (v.0 z)) + ((x.0 x2) (y.0 y2) (u.0 z) (v.0 z)) + ((x.0 x1) (y.0 y1) (u.0 (s z)) (v.0 (s z))) + ((x.0 x2) (y.0 y2) (u.0 (s z)) (v.0 (s z))) + ((x.0 x1) (y.0 y1) (u.0 (s (s z))) (v.0 (s (s z))))) + ) + + ;; Test for nonoverlapping. + + (cout nl "any-union" nl) + (test-check "R1+R2" + (solve 10 (x y) + (any-union (R1 x y) (R2 x y))) + '(((x.0 x1) (y.0 y1)) + ((x.0 x2) (y.0 y2)) + ((x.0 x3) (y.0 y3)))) + + (test-check "R2+R1" + (solve 10 (x y) + (any-union (R2 x y) (R1 x y))) + '(((x.0 x1) (y.0 y1)) + ((x.0 x3) (y.0 y3)) + ((x.0 x2) (y.0 y2)))) + + (test-check "R1+R1" + (solve 10 (x y) + (any-union (R1 x y) (R1 x y))) + '(((x.0 x1) (y.0 y1)) + ((x.0 x2) (y.0 y2)))) + + (test-check "Rinf+R1" + (solve 7 (x y) + (any-union (Rinf x y) (R1 x y))) + '(((x.0 z) (y.0 z)) + ((x.0 x1) (y.0 y1)) + ((x.0 (s z)) (y.0 (s z))) + ((x.0 x2) (y.0 y2)) + ((x.0 (s (s z))) (y.0 (s (s z)))) + ((x.0 (s (s (s z)))) (y.0 (s (s (s z))))) + ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z)))))))) + + (test-check "R1+RInf" + (solve 7 (x y) + (any-union (R1 x y) (Rinf x y))) + '(((x.0 x1) (y.0 y1)) + ((x.0 z) (y.0 z)) + ((x.0 x2) (y.0 y2)) + ((x.0 (s z)) (y.0 (s z))) + ((x.0 (s (s z))) (y.0 (s (s z)))) + ((x.0 (s (s (s z)))) (y.0 (s (s (s z))))) + ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z)))))))) + + + ; Infinitary relation Rinf2 + ; r(z,z). + ; r(s(s(X)),s(s(Y))) :- r(X,Y). + ; Rinf2 overlaps with Rinf in the infinite number of points + (letrec + ((Rinf2 + (extend-relation (a1 a2) + (fact () 'z 'z) + (relation (x y t1 t2) + (to-show t1 t2) + (all + (== t1 `(s (s ,x))) + (== t2 `(s (s ,y))) + (Rinf2 x y))))) + ) + (test-check "Rinf2" + (solve 5 (x y) (Rinf2 x y)) + '(((x.0 z) (y.0 z)) + ((x.0 (s (s z))) (y.0 (s (s z)))) + ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z)))))) + ((x.0 (s (s (s (s (s (s z))))))) + (y.0 (s (s (s (s (s (s z)))))))) + ((x.0 (s (s (s (s (s (s (s (s z))))))))) + (y.0 (s (s (s (s (s (s (s (s z)))))))))))) + + (test-check "Rinf+Rinf2" + (solve 9 (x y) + (any-union (Rinf x y) (Rinf2 x y))) + '(((x.0 z) (y.0 z)) + ((x.0 (s z)) (y.0 (s z))) + ((x.0 (s (s z))) (y.0 (s (s z)))) + ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z)))))) + ((x.0 (s (s (s z)))) (y.0 (s (s (s z))))) + ((x.0 (s (s (s (s (s (s z))))))) + (y.0 (s (s (s (s (s (s z)))))))) + ((x.0 (s (s (s (s (s (s (s (s z))))))))) + (y.0 (s (s (s (s (s (s (s (s z)))))))))) + ((x.0 (s (s (s (s (s z)))))) (y.0 (s (s (s (s (s z))))))) + ((x.0 (s (s (s (s (s (s (s (s (s (s z))))))))))) + (y.0 (s (s (s (s (s (s (s (s (s (s z)))))))))))))) + + (test-check "Rinf2+Rinf" + (solve 9 (x y) + (any-union (Rinf2 x y) (Rinf x y))) + '(((x.0 z) (y.0 z)) + ((x.0 (s z)) (y.0 (s z))) + ((x.0 (s (s z))) (y.0 (s (s z)))) + ((x.0 (s (s (s z)))) (y.0 (s (s (s z))))) + ((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z)))))) + ((x.0 (s (s (s (s (s z)))))) (y.0 (s (s (s (s (s z))))))) + ((x.0 (s (s (s (s (s (s z))))))) + (y.0 (s (s (s (s (s (s z)))))))) + ((x.0 (s (s (s (s (s (s (s z)))))))) + (y.0 (s (s (s (s (s (s (s z))))))))) + ((x.0 (s (s (s (s (s (s (s (s z))))))))) + (y.0 (s (s (s (s (s (s (s (s z)))))))))))) + ))) + + + (cout nl "Append with limited depth" nl) + ; In Prolog, we normally write: + ; append([],L,L). + ; append([X|L1],L2,[X|L3]) :- append(L1,L2,L3). + ; + ; If we switch the clauses, we get non-termination. + ; In our system, it doesn't matter! + + (letrec + ((extend-clause-1 + (relation (l) + (to-show '() l l) + succeed)) + (extend-clause-2 + (relation (x l1 l2 l3) + (to-show `(,x . ,l1) l2 `(,x . ,l3)) + (extend-rel l1 l2 l3))) + (extend-rel + (extend-relation-with-recur-limit 5 (a b c) + extend-clause-1 + extend-clause-2)) + ) + + ; Note (solve 100 ...) + ; Here 100 is just a large number: we want to print all solutions + (cout nl "Extend: clause1 first: " + (solve 100 (a b c) (extend-rel a b c)) + nl)) + + (letrec + ((extend-clause-1 + (relation (l) + (to-show '() l l) + succeed)) + (extend-clause-2 + (relation (x l1 l2 l3) + (to-show `(,x . ,l1) l2 `(,x . ,l3)) + (extend-rel l1 l2 l3))) + (extend-rel + (extend-relation-with-recur-limit 3 (a b c) + extend-clause-2 + extend-clause-1))) + + (cout nl "Extend: clause2 first. In Prolog, it would diverge!: " + (solve 100 (a b c) (extend-rel a b c)) nl)) + + + (letrec + ((base-+-as-relation + (fact (n) 'zero n n)) + (recursive-+-as-relation + (relation (n1 n2 n3) + (to-show `(succ ,n1) n2 `(succ ,n3)) + (plus-as-relation n1 n2 n3))) + ; Needed eta-expansion here: otherwise, SCM correctly reports + ; an error (but Petite doesn't, alas) + ; This is a peculiarity of extend-relation as a macro + ; Potentially, we need the same approach as in minikanren + (plus-as-relation + (extend-relation (a1 a2 a3) + (lambda (a1 a2 a3) (base-+-as-relation a1 a2 a3)) + (lambda (a1 a2 a3) (recursive-+-as-relation a1 a2 a3)) + )) + ) + + (test-check "Addition" + (solve 20 (x y) + (plus-as-relation x y '(succ (succ (succ (succ (succ zero))))))) + '(((x.0 zero) (y.0 (succ (succ (succ (succ (succ zero))))))) + ((x.0 (succ zero)) (y.0 (succ (succ (succ (succ zero)))))) + ((x.0 (succ (succ zero))) (y.0 (succ (succ (succ zero))))) + ((x.0 (succ (succ (succ zero)))) (y.0 (succ (succ zero)))) + ((x.0 (succ (succ (succ (succ zero))))) (y.0 (succ zero))) + ((x.0 (succ (succ (succ (succ (succ zero)))))) (y.0 zero)))) + + (newline) + ) +10) + +;; ======================================================================== +;; type-inference example +;; ======================================================================== + +; Type Inference +; +; We show two variations of Hindley-Milner type inference. Both +; variations support polymorphic, generalizing `let'. Both variations +; use Kanren's logical variables for type variables, and take advantage +; of Kanren's unifier to solve the equations that arise during the course +; of type inference. These features make the Kanren realization of the +; type inference algorithm concise and lucid. +; +; The variations differ in the syntax of the `source' language, and in +; the way type environments are implemented. One variation realizes +; type environments as regular lists, of associations between symbolic +; variable names and their types. The other variation extends the type +; entailment relation (which is a first-class relation in Kanren). The +; latter approach is similar to that of inductive proofs (see files +; ./deduction.scm and ./mirror-equ.scm) +; +; $Id: type-inference.scm,v 4.50 2005/02/12 00:05:01 oleg Exp $ + +; (display "Type inference") (newline) + +; Variation 1: use a subset of Scheme itself as the source language +; The following two functions translate between the source language +; and intermediate one. + +(define parse + (lambda (e) + (cond + ((symbol? e) `(var ,e)) + ((number? e) `(intc ,e)) + ((boolean? e) `(boolc ,e)) + (else (case (car e) + ((zero?) `(zero? ,(parse (cadr e)))) + ((sub1) `(sub1 ,(parse (cadr e)))) + ((+) `(+ ,(parse (cadr e)) ,(parse (caddr e)))) + ((if) `(if ,(parse (cadr e)) ,(parse (caddr e)) ,(parse (cadddr e)))) + ((fix) `(fix ,(parse (cadr e)))) + ((lambda) `(lambda ,(cadr e) ,(parse (caddr e)))) + ((let) `(let ((,(car (car (cadr e))) ,(parse (cadr (car (cadr e)))))) + ,(parse (caddr e)))) + (else `(app ,(parse (car e)) ,(parse (cadr e))))))))) + +(define unparse + (lambda (e) + (case (car e) + ((var) (cadr e)) + ((intc) (cadr e)) + ((boolc) (cadr e)) + ((zero?) `(zero? ,(unparse (cadr e)))) + ((sub1) `(sub1 ,(unparse (cadr e)))) + ((+) `(+ ,(unparse (cadr e)) ,(unparse (caddr e)))) + ((if) `(if ,(unparse (cadr e)) ,(unparse (caddr e)) ,(unparse (cadddr e)))) + ((fix) `(fix ,(unparse (cadr e)))) + ((lambda) `(lambda (,(car (cadr e))) ,(unparse (caddr e)))) + ((let) + `(let ((,(car (car (cadr e))) + ,(unparse (cadr (car (cadr e)))))) + ,(unparse (caddr e)))) + ((app) `(,(unparse (cadr e)) ,(unparse (caddr e))))))) + +; Type environments +; +; A type environment (often denoted as \Gamma, or g in this code) +; is an association between the names of variables of source language +; terms and the types of those variables. +; As a side condition, each variable may occur in the list +; exactly once. +; Hmm, to model lexical scope better, we may relax that condition. +; +; Here we implement type environments as regular associative lists, +; lists of triples: +; ( non-generic ) +; ( generic ) +; +; is a symbolic name of a source term variable. +; is a type term, e.g., int, bool, (--> int bool), etc. +; may include logical variables, which are treated then as +; type variables. +; +; The association '( generic )' asserts that +; is given a _generic_ type. then is a +; predicate of arity 1. To be more precise, ( ) +; is an goal that succeeds or fails depending on the fact if +; is an instance of a generic type represented by . +; +; This is precisely the logical meaning of generalization, as +; pointed out by Ken: +;
+; A cleaner, but less efficient, formulation of HM type inference is to +; use the following let rule instead: +; +; Gamma |- M : t Gamma |- N[M/x] : t' +; -------------------------------------- Let +; Gamma |- let x = M in N : t' +; +; Look ma, no FV! In words, this rule treats let as a construct for +; syntactic substitution. This means storing either M, or a thunk +; returning (a logical variable associated with a fresh copy of) the type +; of M, under x in the environment. This formulation avoids var? while +; taking advantage of built-in unification (to some extent). +;
+; +; We must emphasize that in Kanren, relations are first-class, and may, +; therefore, be included as parts of a data structure: of an associative +; list in our case. + +; Because type environments are regular lists, we can build them using +; regular cons. The empty type environemnt is the empty list. The +; following is a Kanren relation that searches the associative +; list. We are interested in the first match. + +; The following is a general-purpose function +; (membero v l) holds if v is a member of the list l. +; 'v' must be sufficiently instantiated (at least, the search key +; must be instantiated, to justify our use of the committed choice +; non-determinism). +(define membero + (relation (v lt lh) + (to-show v `(,lh . ,lt)) + (if-some (== v lh) succeed + (membero v lt)))) + +; The following is the type-environment-specific function. +; (env g v t) holds if the source term variable v has a type t +; in the environment g. +; We require that 'v' be instantiated, to justify our use +; of the committed choice non-determinism (e.g., membero). + +(define env + (relation (head-let g v t) + (_exists (tq) + (all!! + (membero `(,v . ,tq) g) + (any + (== tq `(non-generic ,t)) + (_exists (type-gen) + (all!! + (== tq `(generic ,type-gen)) + (project (type-gen) + (type-gen t))))))))) + +;;;; This starts the rules + +(define int 'int) +(define bool 'bool) + +(define var-rel + (relation (g v t) + (to-show g `(var ,v) t) + (all! (env g v t)))) + +(define int-rel + (fact (g x) g `(intc ,x) int)) + +(define bool-rel + (fact (g x) g `(boolc ,x) bool)) + +(define zero?-rel + (relation (g x) + (to-show g `(zero? ,x) bool) + (all! (!- g x int)))) + +(define sub1-rel + (relation (g x) + (to-show g `(sub1 ,x) int) + (all! (!- g x int)))) + +(define plus-rel + (relation (g x y) + (to-show g `(+ ,x ,y) int) + (all!! (!- g x int) (!- g y int)))) + +(define if-rel + (relation (g t test conseq alt) + (to-show g `(if ,test ,conseq ,alt) t) + (all!! (!- g test bool) (!- g conseq t) (!- g alt t)))) + +(define lambda-rel + (relation (g v t body type-v) + (to-show g `(lambda (,v) ,body) `(a--> ,type-v ,t)) + (all! (!- `((,v non-generic ,type-v) . ,g) body t)))) + +(define app-rel + (relation (g t rand rator) + (to-show g `(app ,rator ,rand) t) + (_exists (t-rand) + (all!! (!- g rator `(a--> ,t-rand ,t)) (!- g rand t-rand))))) + +(define fix-rel + (relation (g rand t) + (to-show g `(fix ,rand) t) + (all! (!- g rand `(a--> ,t ,t))))) + +; Type-checking polymorphic let: (let ([,v ,rand]) ,body) +; There is obviously an inefficiency, because we typecheck `rand' +; every time the variable `v' occurs in the body (and once more). +; We can fix it, with copy term. But for now, we leave this optimization out. +; The reason to test `(!- g rand some-type)' at the very beginning is +; to make sure that `rand' itself is well-typed. As Ken pointed out, +; we must outlaw expressions such as (let ((x (z z))) y) where 'x' +; does not occur in the body. The variable 'x' still must have some +; type. + +(define polylet-rel + (relation (g v rand body t) + (to-show g `(let ((,v ,rand)) ,body) t) + (all!! + (_exists (some-type) (!- g rand some-type)) + (!- `((,v generic ,(relation (head-let t-rand) + (all!! + (!- g rand t-rand) + (trace-vars 'poly-let (t-rand rand))))) + . ,g) + body t)))) + + +(define !- + (extend-relation (a1 a2 a3) + var-rel int-rel bool-rel zero?-rel sub1-rel plus-rel + if-rel lambda-rel app-rel fix-rel polylet-rel)) + +(define (ti-tests) +(test-check 'test-!-1 + (and + (equal? + (solution (?) (!- '() '(intc 17) int)) + '((?.0 _.0))) + (equal? + (solution (?) (!- '() '(intc 17) ?)) + '((?.0 int)))) + #t) + +(test-check 'arithmetic-primitives + (solution (?) (!- '() '(zero? (intc 24)) ?)) + '((?.0 bool))) + +(test-check 'test-!-sub1 + (solution (?) (!- '() '(zero? (sub1 (intc 24))) ?)) + '((?.0 bool))) + +(test-check 'test-!-+ + (solution (?) + (!- '() '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?)) + '((?.0 bool))) + +(test-check 'test-!-2 + (and + (equal? + (solution (?) (!- '() '(zero? (intc 24)) ?)) + '((?.0 bool))) + (equal? + (solution (?) (!- '() '(zero? (+ (intc 24) (intc 50))) ?)) + '((?.0 bool))) + (equal? + (solution (?) + (!- '() '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?)) + '((?.0 bool)))) + #t) + +(test-check 'test-!-3 + (solution (?) (!- '() '(if (zero? (intc 24)) (intc 3) (intc 4)) ?)) + '((?.0 int))) + +(test-check 'if-expressions + (solution (?) + (!- '() '(if (zero? (intc 24)) (zero? (intc 3)) (zero? (intc 4))) ?)) + '((?.0 bool))) + +(test-check 'variables + (and + (equal? + (solution (?) + (env '((b non-generic int) (a non-generic bool)) 'a ?)) + '((?.0 bool))) + (equal? + (solution (?) + (!- '((a non-generic int)) '(zero? (var a)) ?)) + '((?.0 bool))) + (equal? + (solution (?) + (!- '((b non-generic bool) (a non-generic int)) + '(zero? (var a)) + ?)) + '((?.0 bool)))) + #t) + +(test-check 'variables-4a + (solution (?) + (!- '((b non-generic bool) (a non-generic int)) + '(lambda (x) (+ (var x) (intc 5))) + ?)) + '((?.0 (a--> int int)))) + +(test-check 'variables-4b + (solution (?) + (!- '((b non-generic bool) (a non-generic int)) + '(lambda (x) (+ (var x) (var a))) + ?)) + '((?.0 (a--> int int)))) + +(test-check 'variables-4c + (solution (?) + (!- '() '(lambda (a) (lambda (x) (+ (var x) (var a)))) ?)) + '((?.0 (a--> int (a--> int int))))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!- '() (parse + '(lambda (f) + (lambda (x) + ((f x) x)))) + ?)) + '((?.0 (a--> + (a--> _.0 (a--> _.0 _.1)) + (a--> _.0 _.1))))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!- '() + (parse + '((fix (lambda (sum) + (lambda (n) + (if (zero? n) + 0 + (+ n (sum (sub1 n))))))) + 10)) + ?)) + '((?.0 int))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!- '() + (parse + '((fix (lambda (sum) + (lambda (n) + (+ n (sum (sub1 n)))))) + 10)) + ?)) + '((?.0 int))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!- '() + (parse '((lambda (f) + (if (f (zero? 5)) + (+ (f 4) 8) + (+ (f 3) 7))) + (lambda (x) x))) + ?)) + #f) + +(test-check 'polymorphic-let + (solution (?) + (!- '() + (parse + '(let ((f (lambda (x) x))) + (if (f (zero? 5)) + (+ (f 4) 8) + (+ (f 3) 7)))) + ?)) + '((?.0 int))) + +(test-check 'with-robust-syntax + (solution (?) + (!- '() + '(app + (fix + (lambda (sum) + (lambda (n) + (if (if (zero? (var n)) (boolc #t) (boolc #f)) + (intc 0) + (+ (var n) (app (var sum) (sub1 (var n)))))))) + (intc 10)) + ?)) + '((?.0 int))) + +(test-check 'with-robust-syntax-but-long-jumps/poly-let + (solution (?) + (!- '() + '(let ((f (lambda (x) (var x)))) + (if (app (var f) (zero? (intc 5))) + (+ (app (var f) (intc 4)) (intc 8)) + (+ (app (var f) (intc 3)) (intc 7)))) + ?)) + '((?.0 int))) + +(test-check 'type-habitation-1 + (solution (g ?) + (!- g ? '(a--> int int))) + '((g.0 ((_.0 non-generic (a--> int int)) . _.1)) (?.0 (var _.0)))) + +(test-check 'type-habitation-2 + (solution (g h r q z y t) + (!- g `(,h ,r (,q ,z ,y)) t)) + '((g.0 ((_.0 non-generic int) . _.1)) + (h.0 +) + (r.0 (var _.0)) + (q.0 +) + (z.0 (var _.0)) + (y.0 (var _.0)) + (t.0 int)) +) + +(test-check 'type-habitation-3 + (and + (equal? + (solution (la f b) + (!- '() `(,la (,f) ,b) '(a--> int int))) + '((la.0 lambda) (f.0 _.0) (b.0 (var _.0)))) + (equal? + (solution (h r q z y t u v) + (!- '() `(,h ,r (,q ,z ,y)) `(,t ,u ,v))) + '((h.0 lambda) + (r.0 (_.0)) + (q.0 +) + (z.0 (var _.0)) + (y.0 (var _.0)) + (t.0 a-->) + (u.0 int) + (v.0 int)))) + #t) + +10) + +;---------------------------------------------------------------------- +; A different implementation of type environments +; We define a first-class (and recursive) relation !- +; so that (!- `(var ,v) t) holds iff the source term variable v has a type +; t. +; This variant is close to the `natural deduction' scheme. +; It also has an OO flavor: we need open recursion. + +; The following are the separate components of which the relation +; !- will be built. All these components nevertheless receive the full +; !- as the argument. Actually, they will receive the 'self'-like +; argument. We need to explicitly find the fixpoint. + +; (cout nl "Natural-deduction-like type inference" nl nl) + + +(define pint-rel + (lambda (s!-) + (fact (x) `(intc ,x) int))) + +(define pbool-rel + (lambda (s!-) + (fact (x) `(boolc ,x) bool))) + +(define pzero?-rel + (lambda (s!-) + (let ((!- (s!- s!-))) + (relation (x) + (to-show `(zero? ,x) bool) + (all! (!- x int)))))) + +(define psub1-rel + (lambda (s!-) + (let ((!- (s!- s!-))) + (relation (x) + (to-show `(sub1 ,x) int) + (all! (!- x int)))))) + +(define p+-rel + (lambda (s!-) + (let ((!- (s!- s!-))) + (relation (x y) + (to-show `(+ ,x ,y) int) + (all!! (!- x int) (!- y int)))))) + +(define pif-rel + (lambda (s!-) + (let ((!- (s!- s!-))) + (relation (t test conseq alt) + (to-show `(if ,test ,conseq ,alt) t) + (all!! (!- test bool) (!- conseq t) (!- alt t)))))) + +; Here we extend !- with an additional assumption that v has the type +; type-v. This extension corresponds to a non-generic, regular type. +(define plambda-rel + (lambda (s!-) + (relation (v t body type-v) + (to-show `(lambda (,v) ,body) `(a--> ,type-v ,t)) + (let* ((snew-!- + (lambda (self) + (extend-relation (v t) + (fact () `(var ,v) type-v) ; lexically-scoped relation + (s!- self)))) + (!- (snew-!- snew-!-))) + (all! (!- body t)))))) + + +(define papp-rel + (lambda (s!-) + (let ((!- (s!- s!-))) + (relation (t rand rator) + (to-show `(app ,rator ,rand) t) + (_exists (t-rand) + (all!! (!- rator `(a--> ,t-rand ,t)) (!- rand t-rand))))))) + +(define pfix-rel + (lambda (s!-) + (let ((!- (s!- s!-))) + (relation (rand t) + (to-show `(fix ,rand) t) + (all! (!- rand `(a--> ,t ,t))))))) + +; Type-checking polymorphic let: (let ((,v ,rand)) ,body) +; There is obviously an inefficiency, because we typecheck `rand' +; every time the variable `v' occurs in the body (and once more). +; We can fix it, with copy term. But for now, we leave this optimization out. +; The reason to test `(!- g rand some-type)' at the very beginning is +; to make sure that `rand' itself is well-typed. As Ken pointed out, +; we must outlaw expressions such as (let ((x (z z))) y) where 'x' +; does not occur in the body. The variable 'x' still must have some +; type. + +(define ppolylet-rel + (lambda (s!-) + (let ((!- (s!- s!-))) + (relation (v rand body t) + (to-show `(let ((,v ,rand)) ,body) t) + (all!! + (_exists (some-type) (!- rand some-type)) + (let* ((snew-!- + (lambda (self) + (extend-relation (v t) + (relation (head-let `(var ,v) t-rand) + (all!! + (!- rand t-rand) + (trace-vars 'poly-let (t-rand rand)))) + (s!- self)))) + (!- (snew-!- snew-!-))) + (!- body t))))))) + +; Now we build the recursive !- relation, as a fixpoint + +(define s!- + (lambda (self) + (lambda (v t) + ((extend-relation (a1 a2) + (pint-rel self) + (pbool-rel self) (pzero?-rel self) + (psub1-rel self) (p+-rel self) + (pif-rel self) (plambda-rel self) + (papp-rel self) (pfix-rel self) + (ppolylet-rel self)) v t)))) + +(define !-/2 (s!- s!-)) + + +; And we re-do all the tests + +(define (ti-tests-2) + +(test-check 'test-!-1 + (and + (equal? + (solution (?) (!-/2 '(intc 17) int)) + '((?.0 _.0))) + (equal? + (solution (?) (!-/2 '(intc 17) ?)) + '((?.0 int)))) + #t) + +(test-check 'arithmetic-primitives + (solution (?) (!-/2 '(zero? (intc 24)) ?)) + '((?.0 bool))) + +(test-check 'test-!-sub1 + (solution (?) (!-/2 '(zero? (sub1 (intc 24))) ?)) + '((?.0 bool))) + +(test-check 'test-!-+ + (solution (?) + (!-/2 '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?)) + '((?.0 bool))) + +(test-check 'test-!-2 + (and + (equal? + (solution (?) (!-/2 '(zero? (intc 24)) ?)) + '((?.0 bool))) + (equal? + (solution (?) (!-/2 '(zero? (+ (intc 24) (intc 50))) ?)) + '((?.0 bool))) + (equal? + (solution (?) + (!-/2 '(zero? (sub1 (+ (intc 18) (+ (intc 24) (intc 50))))) ?)) + '((?.0 bool)))) + #t) + +(test-check 'test-!-3 + (solution (?) (!-/2 '(if (zero? (intc 24)) (intc 3) (intc 4)) ?)) + '((?.0 int))) + +(test-check 'if-expressions + (solution (?) + (!-/2 '(if (zero? (intc 24)) (zero? (intc 3)) (zero? (intc 4))) ?)) + '((?.0 bool))) + +; Commented out: we need to extend !- if we wish to typecheck open terms +'(test-check 'variables + (and + (equal? + (solution (?) + (env '((b non-generic int) (a non-generic bool)) 'a ?)) + '((?.0 bool))) + (equal? + (solution (?) + (!-/2 '((a non-generic int)) '(zero? (var a)) ?)) + '((?.0 bool))) + (equal? + (solution (?) + (!-/2 '((b non-generic bool) (a non-generic int)) + '(zero? (var a)) + ?)) + '((?.0 bool)))) + #t) + +(test-check 'variables-4a + (solution (?) + (!-/2 '(lambda (x) (+ (var x) (intc 5))) + ?)) + '((?.0 (a--> int int)))) + +; Commented out: we need to extend !- if we wish to typecheck open terms +'(test-check 'variables-4b + (solution (?) + (!-/2 '((b non-generic bool) (a non-generic int)) + '(lambda (x) (+ (var x) (var a))) + ?)) + '((?.0 (a--> int int)))) + +(test-check 'variables-4c + (solution (?) + (!-/2 '(lambda (a) (lambda (x) (+ (var x) (var a)))) ?)) + '((?.0 (a--> int (a--> int int))))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!-/2 (parse + '(lambda (f) + (lambda (x) + ((f x) x)))) + ?)) + '((?.0 (a--> + (a--> _.0 (a--> _.0 _.1)) + (a--> _.0 _.1))))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!-/2 (parse + '((fix (lambda (sum) + (lambda (n) + (if (zero? n) + 0 + (+ n (sum (sub1 n))))))) + 10)) + ?)) + '((?.0 int))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!-/2 (parse + '((fix (lambda (sum) + (lambda (n) + (+ n (sum (sub1 n)))))) + 10)) + ?)) + '((?.0 int))) + +(test-check 'everything-but-polymorphic-let + (solution (?) + (!-/2 (parse '((lambda (f) + (if (f (zero? 5)) + (+ (f 4) 8) + (+ (f 3) 7))) + (lambda (x) x))) + ?)) + #f) + +(test-check 'polymorphic-let + (solution (?) + (!-/2 (parse + '(let ((f (lambda (x) x))) + (if (f (zero? 5)) + (+ (f 4) 8) + (+ (f 3) 7)))) + ?)) + '((?.0 int))) + +(test-check 'with-robust-syntax + (solution (?) + (!-/2 '(app + (fix + (lambda (sum) + (lambda (n) + (if (if (zero? (var n)) (boolc #t) (boolc #f)) + (intc 0) + (+ (var n) (app (var sum) (sub1 (var n)))))))) + (intc 10)) + ?)) + '((?.0 int))) + +(test-check 'with-robust-syntax-but-long-jumps/poly-let + (solution (?) + (!-/2 '(let ((f (lambda (x) (var x)))) + (if (app (var f) (zero? (intc 5))) + (+ (app (var f) (intc 4)) (intc 8)) + (+ (app (var f) (intc 3)) (intc 7)))) + ?)) + '((?.0 int))) + +; The latter doesn't work: but it wasn't too informative anyway +'(test-check 'type-habitation-1 + (solution (?) + (!-/2 ? '(a--> int int))) + '((g.0 ((v.0 non-generic (a--> int int)) . lt.0)) (?.0 (var v.0)))) + +(test-check 'type-habitation-2 + (solution (h r q z y t) + (!-/2 `(,h ,r (,q ,z ,y)) t)) + '((h.0 +) + (r.0 (intc _.0)) + (q.0 +) + (z.0 (intc _.1)) + (y.0 (intc _.2)) + (t.0 int)) +) + +(test-check 'type-habitation-3 + (and + (equal? + (solution (la f b) + (!-/2 `(,la (,f) ,b) '(a--> int int))) + '((la.0 lambda) (f.0 _.0) (b.0 (var _.0)))) + (equal? + (solution (h r q z y t u v) + (!-/2 `(,h ,r (,q ,z ,y)) `(,t ,u ,v))) + '((h.0 lambda) + (r.0 (_.0)) + (q.0 +) + (z.0 (var _.0)) + (y.0 (var _.0)) + (t.0 a-->) + (u.0 int) + (v.0 int)))) + #t) +10) + + +; The code below uses the low-level function var? Every use of var? +; entails a proof obligation that such use is safe. In our case here, +; invertible-binary-function->ternary-relation and +; invertible-unary-function->binary-relation are sound. + +(define invertible-binary-function->ternary-relation + (lambda (op inverted-op) + (relation (head-let x y z) + (project/no-check (z) + (if-only (predicate (var? z)) + (project (x y) (== z (op x y))) ; z is free, x and y must not + (project/no-check (y) + (if-only (predicate (var? y)) ; y is free, z is not + (project (x) + (== y (inverted-op z x))) + (project/no-check (x) + (if-only (predicate (var? x)) ; x is free, y and z are not + (== x (inverted-op z y)) + (== z (op x y))))))))))) + + +(define t++ (invertible-binary-function->ternary-relation + -)) +(define t-- (invertible-binary-function->ternary-relation - +)) +(define ** (invertible-binary-function->ternary-relation * /)) +(define // (invertible-binary-function->ternary-relation / *)) + +(define symbol->lnum + (lambda (sym) + (map char->integer (string->list (symbol->string sym))))) + +(define lnum->symbol + (lambda (lnums) + (string->symbol (list->string (map integer->char lnums))))) + +(define invertible-unary-function->binary-relation + (lambda (op inverted-op) + (relation (head-let x y) + (project/no-check (y) + (if-only (predicate (var? y)) + (project (x) (== y (op x))) ; y is free, x must not + (project/no-check (x) + (if-only (predicate (var? x)) + (== x (inverted-op y)) + (== y (op x))))))))) + +(define name + (invertible-unary-function->binary-relation symbol->lnum lnum->symbol)) + +(define (ti-tests-3) +(test-check 'test-instantiated-1 + (and + (equal? + (solution (x) (t++ x 16.0 8)) + '((x.0 -8.0))) + (equal? + (solution (x) (t++ 10 16.0 x)) + '((x.0 26.0))) + (equal? + (solution (x) (t-- 10 x 3)) + '((x.0 13)))) + #t) + +(test-check 'test-instantiated-2 + (and + (equal? + (solution (x) (name 'sleep x)) + '((x.0 (115 108 101 101 112)))) + (equal? + (solution (x) (name x '(115 108 101 101 112))) + '((x.0 sleep)))) + #t) +10) + +;; ======================================================================== +;; typeclasses example +;; ======================================================================== + +;(newline) +;(display "Checking for dependency satisfaction in Haskell typeclasses") +;(newline) +; Suppose we have the following Haskell class and instance declarations +; class C a b c | a b -> c +; instance C a b c => C a (x,y,b) c +; instance C a (a,c,b) c +; +; They will be compiled into the following database of instances, +; which define the class membership. +(define typeclass-C-instance-1 + (relation (a b c x y) + (to-show a `(,x ,y ,b) c) + (typeclass-C a b c))) + +(define typeclass-C-instance-2 + (relation (a b c) + (to-show a `(,a ,c ,b) c) + succeed)) + +(define typeclass-C + (extend-relation (a b c) + typeclass-C-instance-2 + typeclass-C-instance-1)) + +; Run the checker for the dependency a b -> c +; Try to find the counter-example, that is, two members of (C a b c) +; such that a's and b's are the same but the c's are different. + + +(define typeclass-counter-example-query + (lambda (a b c1 c2) + (all + (typeclass-C a b c1) + (typeclass-C a b c2) + (fails (project/no-check (c1 c2) (predicate (*equal? c1 c2))))))) + +; This does loop +;'(define typeclass-C +; (extend-relation (a b c) +; typeclass-C-instance-1 +; typeclass-C-instance-2)) + +(define typeclass-C/x + (extend-relation-with-recur-limit 2 (a b c) + typeclass-C-instance-1 + typeclass-C-instance-2)) + +; (pntall "~%Test: checking dependency satisfaction: Another example.~%") +; Suppose we have the following Haskell class and instance declarations +; class F a b | a->b +; instance F a b => F [a] [b] +; instance F [a] a +; + +(define typeclass-F + (extend-relation-with-recur-limit 10 (a b) + (relation (a b) + (to-show `(list ,a) `(list ,b)) + (typeclass-F a b)) + (fact (a) `(list ,a) a))) + + +; Run the checker for the dependency a -> b +; Try to find the counter-example, that is, two members of (F a b) +; such that as is the same but bs are different. +(define typeclass-F-counter-example-query + (lambda (a b1 b2) + (all + (typeclass-F a b1) + (typeclass-F a b2) + (fails (project/no-check (b1 b2) (predicate (*equal? b1 b2))))))) + +; (pntall "~%Overloading resolution in Haskell.~%") +; Suppose we have the following Haskell class and instance declarations +; class F a b | a->b where f :: a->b->Bool +; instance F a b => F [a] [b] +; +; we need to typecheck +; g x = f [x] x +; which says that f:: [a] -> a -> Bool +; In general, we need to figure out which instance to choose for f. +; In other words, we need to find out which subset of F to use. +; Here's only one instance. So we need to figure out if it applies. + +(define typeclass-F-instance-1 + (relation (a b) + (to-show `(list ,a) `(list ,b)) + (typeclass-F/x a b))) + +; This is a closed-world assumption +(define typeclass-F/x + (extend-relation-with-recur-limit 10 (a b) + typeclass-F-instance-1)) + +; This is an open-world assumption +(define typeclass-F/x2 + (extend-relation-with-recur-limit 2 (a b) + typeclass-F-instance-1 + (relation (a b1 b2) ; a relation under constraint a->b + (to-show a b1) + (fails + (all! + (typeclass-F/x a b2) + (fails (project/no-check (b1 b2) (predicate (*equal? b1 b2))))))) + )) + +(define (tc-tests) + (pntall "~%Counter-example: ~s~%" + (solution (a b c1 c2) + (typeclass-counter-example-query a b c1 c2))) + + (pntall "~%Counter-example: ~s~%" + (solution (a b c1 c2) + (typeclass-counter-example-query a b c1 c2))) + + (pntall "~%Counter-example: ~s~%" + (solve 4 (a b c1 c2) + (typeclass-counter-example-query a b c1 c2))) + + (pntall "~%Counter-example: ~s~%" + (solve 4 (a b1 b2) (typeclass-F-counter-example-query a b1 b2))) + + + (test-check "Typechecking (closed world)" + (solve 4 (a) + (typeclass-F-instance-1 `(list ,a) a)) + '()) ; meaning: does not typecheck! + + + (pntall "~%Typechecking (open world): ~s~%" + (solve 4 (a) (typeclass-F-instance-1 `(list ,a) a))) + + (test-check "Typechecking (open world) f [x] int" + (solve 4 (a) (typeclass-F-instance-1 `(list ,a) 'int)) + '()) ; meaning: does not typecheck! + + 10 + ) + +;; ======================================================================== +;; zebra example +;; ======================================================================== + +; (display "Zebra") (newline) + +; 1. There are five houses in a row, each of a different color +; and inhabited by men of different nationalities, +; with different pets, drinks, and cigarettes. +; 2. The Englishman lives in the red house. +; 3. The Spaniard owns a dog. +; 4. Coffee is drunk in the green house. +; 5. The Ukrainian drinks tea. +; 6. The green house is directly to the right of the ivory house. +; 7. The Old Gold smoker owns snails. +; 8. Kools are being smoked in the yellow house. +; 9. Milk is drunk in the middle house. +; 10. The Norwegian lives in the first house on the left. +; 11. The Chesterfield smoker lives next to the fox owner. +; 12. Kools are smoked in the house next to the house where the horse is kept. +; 13. The Lucky Strike smoker drinks orange juice. +; 14. The Japanese smokes Parliaments. +; 15. The Norwegian lives next to the blue house. + +; (define memb +; (extend-relation (a1 a2) +; (fact (item) item `(,item . ,_)) +; (relation (item rest) (to-show item `(,_ . ,rest)) (memb item rest)))) + +(define memb + (relation (head-let item lst) + (any (== lst `(,item . ,__)) + (_exists (rest) + (if-only (== lst `(,__ . ,rest)) (memb item rest)))))) + + +(define next-to + (relation (head-let item1 item2 rest) + (any (on-right item1 item2 rest) (on-right item2 item1 rest)))) + +(define on-right + (extend-relation (a0 a1 a2) + (fact (item1 item2) item1 item2 `(,item1 ,item2 . ,__)) + (relation ((once item1) (once item2) rest) + (to-show item1 item2 `(,__ . ,rest)) + (on-right item1 item2 rest)))) + +(define zebra + (relation (head-let h) + (if-only + (all! + (== h `((norwegian ,__ ,__ ,__ ,__) ,__ (,__ ,__ milk ,__ ,__) ,__ ,__)) + (memb `(englishman ,__ ,__ ,__ red) h) + (on-right `(,__ ,__ ,__ ,__ ivory) `(,__ ,__ ,__ ,__ green) h) + (next-to `(norwegian ,__ ,__ ,__ ,__) `(,__ ,__ ,__ ,__ blue) h) + (memb `(,__ kools ,__ ,__ yellow) h) + (memb `(spaniard ,__ ,__ dog ,__) h) + (memb `(,__ ,__ coffee ,__ green) h) + (memb `(ukrainian ,__ tea ,__ ,__) h) + (memb `(,__ luckystrikes oj ,__ ,__) h) + (memb `(japanese parliaments ,__ ,__ ,__) h) + (memb `(,__ oldgolds ,__ snails ,__) h) + (next-to `(,__ ,__ ,__ horse ,__) `(,__ kools ,__ ,__ ,__) h) + (next-to `(,__ ,__ ,__ fox ,__) `(,__ chesterfields ,__ ,__ ,__) h) + ) + (all (memb `(,__ ,__ water ,__ ,__) h) + (memb `(,__ ,__ ,__ zebra ,__) h))))) + +;'(_pretty-print +; (time (let loop ((n 100000)) +; (cond +; ((zero? n) 'done) +; (else (solution (h) (zebra h)) +; (loop (sub1 n))))))) + +(define (zebra-test) +(test-check "Zebra" + (values (solution (h) (zebra h))) + '((h.0 ((norwegian kools water fox yellow) + (ukrainian chesterfields tea horse blue) + (englishman oldgolds milk snails red) + (spaniard luckystrikes oj dog ivory) + (japanese parliaments coffee zebra green))))) +10) + +; Sample timing (Pentium IV, 2GHz, 1GB RAM) +; (time (solution (h) ...)) +; 1 collection +; 22 ms elapsed cpu time, including 0 ms collecting +; 27 ms elapsed real time, including 0 ms collecting +; 981560 bytes allocated, including 1066208 bytes reclaimed + +; For version 3.17 of kanren (with head-let ...) +; (time (solution (h) ...)) +; 1 collection +; 19 ms elapsed cpu time, including 0 ms collecting +; 19 ms elapsed real time, including 0 ms collecting +; 788928 bytes allocated, including 1052312 bytes reclaimed +; +; For version of kanren 3.36 (with once annotations) +; This seems to be similar of SWI-Prolog, which gives 0.01 sec +; timing for the equivalent zebra code. +; (time (solution (h) ...)) +; no collections +; 11 ms elapsed cpu time +; 11 ms elapsed real time +; 532912 bytes allocated + +; For version of kanren 4.0 (increased sharing during unification) +; (time (solution (h) ...)) +; no collections +; 7 ms elapsed cpu time +; 8 ms elapsed real time +; 443792 bytes allocated +; For version of kanren 4.1 (detection of bare variables, less garbage) +; no collections +; 8 ms elapsed cpu time +; 9 ms elapsed real time +; 448920 bytes allocated +; For version of kanren 4.50 (subst sk fk order) +; no collections +; 8 ms elapsed cpu time +; 8 ms elapsed real time +; 416864 bytes allocated + +;; ======================================================================== +;; Mirror example +;; ======================================================================== + +; First we need an extendible database of relations. +; We should be able to add to the database later on -- extend +; it with assumptions. +; +; One approach for the database is a finite map (hash table, assoc +; list) from the name of a relation to the procedure that is a relation +; in our system. Or, to make it even better, from a tuple +; (name arity) to the body of the relation. +; This is the approach of Prolog. +; Suppose we have a term (foo ?a ?b ?c) where ?a, ?b and ?c are arbitrary +; terms (logical variables, constants, expressions, etc). +; We would like to check if this term is consistent with (i.e., can +; be proven by) a particular instance of the database. +; First, we need to look up a key (foo 3) in the database. If the +; lookup fails, so does our query. If the lookup succeeds, we get +; a procedure of three arguments. We apply this procedure to +; ?a, ?b, and ?c and obtain an goal, which we can 'solve' +; as usual. + +; In the following, we chose a different approach. We represent the database +; of relations as a relation itself -- we will call it KB. That +; relation takes one argument -- the term to prove, and returns an goal +; that represents the answer (that goal may be 'fail'). +; A database of one fact +; foo(a,b,c). +; in Prolog notation will be represented in our approach as a relation +; (relation _ () (to-show `(foo a b c))) +; If we want to add another relation, say +; bar(X,X). +; we need to _extend_ the above relation with +; (relation _ (x) (to-show `(bar x x))). +; +; This approach is probably less efficient than the first one. It has +; however a redeeming value -- we do not need a separate procedure +; to look up names/arities of relations. We don't need separate procedures +; for extending our database. We can use the existing machinery of +; 'solving' relations for 'solving' the database of relations. +; This approach seems reminiscent of the Futamura projections: +; we use the same engine for meta-evaluations. Bootstrapping. + +; First we define the inductive structure + +; In Athena: +; (structure (BTree S) +; (leaf S) +; (root (BTree S) (BTree S))) + +; In Prolog +; btree(leaf(S)). +; btree(root(T1,T2)) :- btree(T1),btree(T2). + +; Note, our trees here (as well as those in Prolog) are polytypic +; (polymorphic): leaves can have values of different sorts. + +; When we attempt to translate +; btree(root(T1,T2)) :- btree(T1),btree(T2). +; into our system, we encounter the first difficulty. To find out +; if a term btree(root(T1,T2)) is consistent with our database of relations, +; we need to check if terms btree(T1) and btree(T2) are consistent. +; Thus, to add btree(root(T1,T2)) to our database, we need to use +; the database itself to verify btree(T1) and btree(T2). Clearly, +; we need a fixpoint. The need for the fixpoint _exists no matter what is +; the representation of the database -- a finite map or a relation. +; Prolog solves the fixpoint problem by making the database global +; and using mutations (similar to the way letrec is implemented in Scheme). +; If we attempt to be purely functional, we must make the fixpoint explicit +; and employ Y. + +; Note, the kb variable below represents the "current" database. +; In our approach, the database is a relation of one argument, +; which is a term to prove. A Second-order relation??? + +(define btree + (lambda (kb) + (extend-relation (t) + (fact (val) `(btree (leaf ,val))) + (relation (t1 t2) + (to-show `(btree (root ,t1 ,t2))) + (project (t1 t2) + (all + (predicate (pntall "btree ~s ~s ~n" t1 t2)) + (kb `(btree ,t1)) + (kb `(btree ,t2)))))))) + +;%> (declare mirror ((S) -> ((BTree S)) (BTree S))) + +; Introduce an equality predicate and the first axiom for mirror +; In Athena: +; (define mirror-axiom-1 +; (forall ?x +; (= (mirror (leaf ?x)) (leaf ?x)))) + +; In Prolog +; myeq(leaf(X),mirror(leaf(X))). + +(define mirror-axiom-eq-1 + (lambda (kb) + (fact (val) `(myeq (leaf ,val) (mirror (leaf ,val)))))) + +; The second axiom +; In Athena: +; (define mirror-axiom-eq-2 +; (forall ?t1 ?t2 +; (= (mirror (root ?t1 ?t2)) +; (root (mirror ?t2) (mirror ?t1))))) + +; In Prolog +; myeq(root(B,A),mirror(root(T1,T2))) :- myeq(A,mirror(T1)),myeq(B,mirror(T2)). + +; implicitly the axiom in Prolog and the one below assume +; the transitivity of myeq. Indeed, one may think that the direct +; translation from Athena to Prolog would be +; +; myeq(mirror(root(T1,T2)),root(mirror(T2),mirror(T1))) +; or +; myeq(mirror(root(T1,T2)),root(B,A)) :- B = T2, A = T1. +; However, Athena actually assumes that B and T2 can be myeq rather +; than merely identical. We also switched the order of arguments +; in myeq, assuming symmetry of myeq. +; It really helped in Prolog. In our system, we could have used +; the same order as in Athena and add: +; myeq(A,A). % reflexivity: identity implies equality +; myeq(A,B) :- myeq(B,A). % symmetry +; Clearly if we add these relations to Prolog code, it will diverge. +; In our system, we can use with-depth to keep divergence in check. +; Still, for simplicity and clarity we will simply model the Prolog solution +; in our code. + +(define mirror-axiom-eq-2 + (lambda (kb) + (relation (a b t1 t2) + (to-show `(myeq (root ,b ,a) (mirror (root ,t1 ,t2)))) + (all + (kb `(myeq ,a (mirror ,t1))) + (kb `(myeq ,b (mirror ,t2))))))) + +; we could also add reflexivity and transitivity and symmetry axioms +; and with-depth to keep them from diverging. + +; Define the goal +; In Athena: +; (define (goal t) +; (= (mirror (mirror t)) t)) + +; In Prolog +; Note, the goal is _equivalent_ to the conjunction of the +; predicates. That's why we couldn't use the standard Prolog +; notation goal(T) :- btree(T), ... +; because the latter would give us only the implication. +; goal(T,[btree(T),myeq(T,mirror(T1)),myeq(T1,mirror(T))]). + +(define goal + (lambda (t) + (let-lv (t1) + (list + `(btree ,t) + `(myeq ,t (mirror ,t1)) + `(myeq ,t1 (mirror ,t)))))) + +; For clarity, the above predicate can be written as two (prolog) relations +; The forward relation: +; (goal t) is implied by (btree t), (myeq t (mirror t1)) and +; (myeq t1 (mirror t)) +; In the above, t is universally quantified and t1 is existentially +; quantified + +(define goal-fwd + (lambda (kb) + (relation (t t1) + (to-show `(goal ,t)) + (all + (kb `(btree ,t)) + (kb `(myeq ,t (mirror ,t1))) + (kb `(myeq ,t1 (mirror ,t))))))) + +; The reverse relation for the goal: +; (goal t) implies (btree t), (myeq t (mirror t1)) and +; (myeq t1 (mirror t)) +; In the above, t is universally quantified and t1 is existentially +; quantified +; Because t1 now appears on the left-hand side, it is represented +; as an eigenvariable (skolem function) rather than a logical variable + +(define goal-rev + (let* ((sk (eigen-variable 'sk)) + (t1-sk (lambda (t) `(,sk ,t)))) + (lambda (kb) + (extend-relation (t) + (relation (t) ; (goal t) => (btree t) + (to-show `(btree ,t)) + (kb `(goal ,t))) + (relation (t) ; (goal t) => (myeq t (mirror t1)) + (to-show `(myeq ,t (mirror ,(t1-sk t)))) + (kb `(goal ,t))) + (relation (t) ; (goal t) => (myeq t1 (mirror t)) + (to-show `(myeq ,(t1-sk t) (mirror ,t))) + (kb `(goal ,t))) + )))) + +; The initial assumptions: just the btree +(define init-kb (Y btree)) + +; Verification engine +; verify-goal PREDS KB +; returns a nullary relation that is the conjunction of preds against the +; assumption base kb +(define verify-goal + (lambda (preds kb) + (cond + ((null? (cdr preds)) (kb (car preds))) + (else (all + (kb (car preds)) + (verify-goal (cdr preds) kb)))))) + +; extend the kb with the list of assumptions +; this is just like 'any' only it's a procedure rather than a syntax +; Why we need universalize? +; Suppose, the list of facts includes +; (fact (x) (foo x)) and (fact (x) (bar x)) +; definitely, we do not want to imply that facts foo and bar _share_ +; the same logical variable. The facts are independent and should +; not have any variables in common. +; Furthermore, we do not want to add +; (fact (x) (foo x)) +; because that would mean exist x. foo x +; We want our facts to be universally quantified. So, we add +; (fact () (foo 'unique-symbol)) +; See the distinction between sigma and pi in Lambda-Prolog. +; We use extend-kb to extend the database with assumptions, which most +; often are universally quantified. + +(define extend-kb + (lambda (facts kb) + (let ((facts (universalize facts))) + (pntall "Extending KB with ~s~%" facts) + (let loop ((facts facts)) + (if (null? facts) kb + (extend-relation (t) + (fact () (car facts)) + (loop (cdr facts)))))))) + +; Here's Athena's induction proof. +; +; (by-induction-on ?t (goal ?t) +; ((leaf x) (!pf (goal (leaf x)) [mirror-axiom-1])) +; ((root t1 t2) +; (!pf (goal (root t1 t2)) [(goal t1) (goal t2) mirror-axiom-2]))) + +; The first part of it, the base case, can be expressed in Prolog +; as follows. +; ?- goal(leaf(X),C),verify(C,[]). +; Here how it looks in our system: +(define (mirror-tests) +(test-check "First check the base case" + (query (_ subst) + (verify-goal (goal '(leaf x)) + (extend-relation (t) (mirror-axiom-eq-1 init-kb) init-kb)) + (reify-subst '() subst)) + '((val.0 x) (t1.0 (leaf x)) (val.0 x) (val.0 x))) + +(test-check "Check the base case, using goal-fwd" + (query (_ subst) + (let ((kb0 + (extend-relation (t) (mirror-axiom-eq-1 init-kb) init-kb))) + (let ((kb1 + (extend-relation (t) (goal-fwd kb0) kb0))) + (kb1 '(goal (leaf x))))) ; note, x is an eigenvariable! + (reify-subst '() subst)) + '((val.0 x) (t1.0 (leaf x)) (val.0 x) (val.0 x) (t.0 (leaf x)))) + +; that is, we obtain the list of subgoals to verify '(leaf x) +; by invoking the function 'goal'. +; we extend the initial database (which contains btree facts) +; with mirror-axiom-eq-1. Thus, mirror-axiom-eq-1 and btree form +; the assumptions. We then verify the subgoals against the assumptions. +; Note that we wrote +; '(leaf x) +; rather than +; (let-lv (x) `(leaf ,x)) +; because we want to prove that (goal '(leaf x)) holds for _all_ x +; rather than for some particular x. +; +; non-empty result printed by the above expressions means success... + + +; The inductive case. +; Now, assume the goal holds for t1 and t2 and check if it holds +; for root(t1,t2) +;?- goal(t1,A1),goal(t2,A2), append(A1,A2,A), goal(root(t1,t2),C), verify(C,A). + +(test-check "Some preliminary checks" + (solution (foo) + (verify-goal '((btree t2)) ; (goal t2) => (btree t2) + (let ((kb0 + (extend-kb (goal 't1) + (extend-kb (goal 't2) init-kb)))) + kb0))) + '((foo.0 _.0))) + +(test-check "Some preliminary checks, using goal-rev" + (solution (foo) + (let ((kb + (Y + (lambda (kb) + (extend-relation (t) + (btree kb) + (goal-rev kb) + (fact () '(goal t1)) + (fact () '(goal t2))))))) + (kb '(btree t2)))) + '((foo.0 _.0))) + +; the above two expressions should give the same result: a non-empty stream +; (with an empty substitution: no variables leak) + +(test-check "Another check" + (solution (foo) + ;(goal t1), (goal t2) => (btree (root t1 t2)) + (verify-goal '((btree t1) (btree t2) + (btree (root t1 t2))) + (let ((kb0 + (extend-kb (goal 't1) + (extend-kb (goal 't2) + (fact () 'nothing))))) + (Y + (lambda (kb) + (extend-relation (t) + kb0 + (btree kb) + (mirror-axiom-eq-2 kb))))))) + '((foo.0 _.0))) + +(test-check "Another check, using goal-rev" + (solution (foo) + (let ((kb + (Y + (lambda (kb) + (extend-relation (t) + (btree kb) + (goal-rev kb) + (mirror-axiom-eq-2 kb) + (fact () '(goal t1)) + (fact () '(goal t2))))))) + (kb '(btree (root t1 t2))))) + '((foo.0 _.0))) + +; now we really need Y because we rely on the clause +; btree(root(T1,T2)) :- btree(T1),btree(T2). +; which is recursive. + +(test-check "Check the inductive case" + (query (_ subst) + (verify-goal (goal '(root t1 t2)) + (let ((kb0 + (extend-kb (goal 't1) + (extend-kb (goal 't2) + (fact () 'initial))))) + (Y + (lambda (kb) + (extend-relation (t) + kb0 + (btree kb) + (mirror-axiom-eq-2 kb)))))) + (cout (reify-subst '() subst) nl) #t) + #t) + +(pntall "~%Check particulars of the inductive case, using goal-rev, goal-fwd ~s~%" + (let ((kb + (Y + (lambda (kb) + (extend-relation (t) + (btree kb) + (fact () '(goal t1)) + (fact () '(goal t2)) + (mirror-axiom-eq-2 kb) + (goal-rev kb) + ))))) + (list + (solve 1 (x) (kb `(myeq (root t1 t2) (mirror ,x)))) + (solve 1 (x) (kb `(myeq ,x (mirror (root t1 t2)))))))) + +(test-check "Check the inductive case, using goal-rev, goal-fwd" + (query (_ subst) + (let ((kb + (Y + (lambda (kb) + (extend-relation (t) + (btree kb) + (fact () '(goal t1)) + (fact () '(goal t2)) + (mirror-axiom-eq-2 kb) + (goal-rev kb)))))) + (let ((kb1 (goal-fwd kb))) + (kb1 '(goal (root t1 t2))))) + (cout (reify-subst '() subst) nl) #t) + #t) + +10) + + +; Again, we use Y because btree and mirror-axiom-eq-2 are recursive. +; We need the database that is the fixpoint of all constituent +; relations. +; The output above is a non-empty list: meaning that the inductive +; phase of the proof checks. + +;; ======================================================================== +;; Mirror-equ example +;; ======================================================================== + +; See mirror.scm for preliminaries + +(define btrii + (lambda (kb) + (extend-relation (t) + (fact (val) `(btrii (leaf ,val))) + (relation (t1 t2) + (to-show `(btrii (root ,t1 ,t2))) + (all + (trace-vars 'btrii (t1 t2)) + (kb `(btrii ,t1)) + (kb `(btrii ,t2))))))) + +(define myeq-axioms + (lambda (kb) + (extend-relation (t) + (fact (val) `(myeq ,val ,val)) ; reflexivity + (relation (a b) + (to-show `(myeq ,a ,b)) ; symmetry + (all + (trace-vars 'symmetry (a b)) + (kb `(myeq ,b ,a)))) + (relation (a b) ; transitivity + (to-show `(myeq ,a ,b)) + (_exists (c) + (all + (kb `(myeq ,a ,c)) + (kb `(myeq ,c ,b))))) + ))) + +(define myeq-axioms-trees ; equational theory of trees + (lambda (kb) ; equality commutes with root + (relation (a b c d) + (to-show `(myeq (root ,a ,b) (root ,c ,d))) + (all + (trace-vars 'trees (a b)) + (kb `(myeq ,a ,c)) + (kb `(myeq ,b ,d)))))) + +; equality on leaves follows from the reflexivity of equality + +(define myeq-axioms-mirror ; equational theory of mirror + (lambda (kb) ; equality commutes with root + (extend-relation (t) + (relation (a b) + (to-show `(myeq (mirror ,a) ,b)) + (all + (trace-vars 'mirror (a b)) + (_exists (c) + (all (kb `(myeq ,b (mirror ,c))) + (kb `(myeq ,a ,c))))))))) + +; Axioms of mirror +; In Prolog +; myeq(leaf(X),mirror(leaf(X))). + +(define mirror-axiom-eq-1/x + (lambda (kb) + (fact (val) `(myeq (leaf ,val) (mirror (leaf ,val)))))) + + +; The second axiom +; In Athena: +; (define mirror-axiom-eq-2/x +; (forall ?t1 ?t2 +; (= (mirror (root ?t1 ?t2)) +; (root (mirror ?t2) (mirror ?t1))))) + +(define mirror-axiom-eq-2/x + (lambda (kb) + (relation (t1 t2) + (to-show `(myeq (mirror (root ,t1 ,t2)) (root (mirror ,t2) (mirror ,t1)))) + (trace-vars 'mirror-ax2 (t1 t2))))) + +; Define the goal +; In Athena: +; (define (goal t) +; (= (mirror (mirror t)) t)) + +(define goal/x + (lambda (t) + (list + `(btrii ,t) + `(myeq (mirror (mirror ,t)) ,t)))) + +(define goal-fwd/x + (lambda (kb) + (relation (t) + (to-show `(goal/x ,t)) + (all + (kb `(btrii ,t)) + (kb `(myeq (mirror (mirror ,t)) ,t)))))) + +(define goal-rev/x + (lambda (kb) + (extend-relation (t) + (relation (t) ; (goal t) => (btrii t) + (to-show `(btrii ,t)) + (kb `(goal/x ,t))) + (relation (t) ; (goal t) => (myeq (mirror (mirror t)) t) + (to-show `(myeq (mirror (mirror ,t)) ,t)) + (kb `(goal/x ,t)))))) + +; (by-induction-on ?t (goal ?t) +; ((leaf x) (!pf (goal (leaf x)) [mirror-axiom-1])) +; ((root t1 t2) +; (!pf (goal (root t1 t2)) [(goal t1) (goal t2) mirror-axiom-2]))) + + + +(define-syntax un@ ; uncurry + (syntax-rules () + ((_ proc arg1 ...) + (lambda (arg1 ...) (at@ proc arg1 ...))))) + +; The initial assumptions: just the btrii +;(define init-kb (Y btrii)) +; Note that in order to be effective, +; extend-relation-with-recur-limit should not be under lambda! +; We want to use the same recursion count for all +; entrances to init-kb-coll. +; Also note that the limit 5 is the number of axioms in init-kb-coll +; plus one. This count will guarantee that each axiom will be tried +; once, but not more than twice. +(define init-kb-coll + (extend-relation-with-recur-limit 5 (kb t) + (un@ btrii kb t) + (un@ myeq-axioms kb t) + (un@ myeq-axioms-mirror kb t) + (un@ myeq-axioms-trees kb t))) + +(define (mirror-equ-tests) +(test-check "First check the base case, using goal-fwd" + (query (_ subst) + (let ((kb0 + (Y (lambda (kb) + (extend-relation (t) + (mirror-axiom-eq-1/x kb) + (lambda (t) (init-kb-coll kb t))))))) + (let ((kb1 + (extend-relation (t) (goal-fwd/x kb0) kb0))) + (kb1 '(goal/x (leaf x))))) ; note, x is an eigenvariable! + ;(cout (reify-subst '() subst) nl) + #t) + #t) + +; (goal t2) => (btrii t2) +(test-check "Some preliminary checks, using goal-rev" + (query (_ subst) + (let ((kb + (Y + (lambda (kb) + (extend-relation (t) + (lambda (t) (init-kb-coll kb t)) + (goal-rev/x kb) + (fact () '(goal/x t1)) + (fact () '(goal/x t2))))))) + (kb '(btrii t2))) + ;(cout (reify-subst '() subst) nl) + #t) + #t) + +(test-check "Another check, using goal-rev" + ;(goal t1), (goal t2) => (btrii (root t1 t2)) + (query (_ subst) + (let ((kb + (Y + (lambda (kb) + (extend-relation (t) + (lambda (t) (init-kb-coll kb t)) + (goal-rev/x kb) + (mirror-axiom-eq-2/x kb) + (fact () '(goal/x t1)) + (fact () '(goal/x t2))))))) + (kb '(btrii (root t1 t2)))) + (cout (reify-subst '() subst) nl) + #t) + #t) + +(pntall "~%Check particulars of the inductive case, using goal-rev, goal-fwd ~s~%" + (let ((kb + (Y + (lambda (kb) + (extend-relation (t) + (lambda (t) (init-kb-coll kb t)) + (fact () '(goal/x t1)) + (fact () '(goal/x t2)) + (mirror-axiom-eq-2/x kb) + (goal-rev/x kb) + ))))) + (list + ;(solve 1 (x) (kb `(myeq (root t1 t2) (mirror ,x)))) + (solve 1 (x) (kb `(myeq ,x (mirror (root t1 t2))))) + ))) + +10) + +;; ======================================================================== +;; pure bin arith example +;; ======================================================================== + +; Pure, declarative, and constructive binary arithmetics +; +; aka: Addition, Multiplication, Division with remainder +; as sound and complete, pure and declarative relations that can be +; used in any mode whatsoever and that recursively enumerate their domains. +; The relations define arithmetics over base-2 non-negative numerals +; of *arbitrary* size. +; +; aka: division as relation. +; The function divo below is a KANREN relation between four binary numerals +; n, m, q, and r such that the following holds +; _exists r. 0<=r0! +; +; We give two implementations of addition and multiplication +; relations, `++o' and `**o'. Both versions have the properties of +; soundness and nealy refutational completeness. The first version of `++o' +; is faster, but it does not always recursively enumerate its domain +; if that domain is infinite. This is the case when, e.g., (**o x y +; z) is invoked when all three x, y, and z are uninstantiated +; variables. The relation in that case has the infinite number of +; solutions, as expected. Alas, those solutions look as follows: +; x = 2, y = 3, z = 6 +; x = 4, y = 3, z = 12 +; x = 8, y = 3, z = 24 +; x = 16, y = 3, z = 48 +; That is, (**o x y z) keeps generating solutions where x is a power of +; two. Therefore, when the answerset of the relation `**o' is infinite, it +; truly produces an infinite set of solutions -- but only the subset of +; all possible solutions. In other words, `**o' does not recursively +; enumerate the set of all numbers such that x*y=z if that set is infinite. +; +; Therefore, +; (all (== x '(1 1)) (== y '(1 1)) (**o x y z)) +; (all (**o x y z) (== x '(1 1)) (== y '(1 1))) +; work differently. The former terminates and binds z to the representation +; of 9 (the product of 3 and 3). The latter fails to terminate. +; This is not generally surprising as `all', like 'commas' in Prolog, +; is not truly a conjunction: they are not commutative. Still, +; we would like our `++o' and `**o' to have the algebraic properties +; expected of addition and multiplication. +; +; The second version of `++o' and `**o' completely fixes the +; problem without losing any performance. The addition and +; multiplication relations completely enumerate their domain, even if +; it is infinite. Furthermore, ++o and **o now generate the numbers +; _in sequence_, which is quite pleasing. We achieve the +; property of recursive enumerability without giving up neither +; completeness nor refutational completeness. As before, if 'z' is +; instantiated but 'x' and 'y' are not, (++o x y z) delivers *all* +; non-negative numbers that add to z and (**o x y z) computes *all* +; factorizations of z. +; +; Such relations are easy to implement in an impure system such as Prolog, +; with the help of a predicate 'var'. The latter can tell if its argument +; is an uninstantiated variable. However, 'var' is impure. The present +; file shows the implementation of arithmetic relations in a _pure_ +; logic system. +; +; The present approach places the correct upper bounds on the +; generated numbers to make sure the search process will terminate. +; Therefore, our arithmetic relations are not only sound +; (e.g., if (**o X Y Z) holds then it is indeed X*Y=Z) but also +; complete (if X*Y=Z is true then (**o X Y Z) holds) and +; nearly refutationally complete (if X*Y=Z is false and X, Y, and Z +; are either fully instantiated, or not instantiated, then (**o X Y Z) fails, +; in finite time). The refutational completeness +; claim is limited to the case when all terms passed to arithmetical +; functions do not share variables, are either fully instantiated or not +; instantiated at all. Indeed, sharing of variables or partial +; instantiation essentially imposes the constraint: e.g., +; (solution (q) (**o `(1 . ,q) `(1 1) `(1 . ,q))) +; is tantamount to +; (solution (q) (exist (q1) +; (all (**o `(1 . ,q) `(1 1) `(1 . ,q1)) (== q q1)))) +; That conjunction will never succeed. See the corresponding Prolog +; code for justification and relation to the 10th Hilbert problem. +; +; The numerals are represented in the binary little-endian +; (least-significant bit first) notation. The higher-order bit must be 1. +; () represents 0 +; (1) represents 1 +; (0 1) represents 2 +; (1 1) represents 3 +; (0 0 1) represents 4 +; etc. +; + + +; There is a Prolog version of this code, which has termination proofs. +; +; $Id: pure-bin-arithm.scm,v 4.50 2005/02/12 00:04:49 oleg Exp $ + +; Auxiliary functions to build and show binary numerals +; +(define (build n) + (if (zero? n) '() (cons (if (even? n) 0 1) (build (quotient n 2))))) + +(define (trans n) + (if (null? n) 0 (+ (car n) (* 2 (trans (cdr n)))))) + + +; (zeroo x) holds if x is zero numeral +(define zeroo + (fact () '())) + +; Not a zero +(define pos + (fact () `(,__ . ,__))) + +; At least two +(define gt1 + (fact () `(,__ ,__ . ,__))) + +; compare the lengths of two numerals +; (
    0, or if (floor (log2 a)) < (floor (log2 b)) +; That is, we compare the length (logarithms) of two numerals +; For a positive numeral, its bitlength = (floor (log2 n)) + 1 +; We also make sure that 'n' is a well-formed number. +(define
      0 or +; length(p1) < min(length(p), length(n) + length(m) + 1) +(define = 2 +; (_exists (r1 r2) +; (all (== r `(,r1 ,r2)) +; (half-adder carry-in 1 1 r1 r2)))) +; +; ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0 +; (relation (carry-in bb br rb rr) +; (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr)) +; (all +; (pos br) (pos rr) +; (_exists (carry-out) +; (all +; (half-adder carry-in 1 bb rb carry-out) +; (full-adder carry-out '() br rr))))) +; +; ; symmetric case for the above +; (relation (head-let carry-in a '(1) r) +; (all +; (gt1 a) (gt1 r) +; (full-adder carry-in '(1) a r))) +; +; ; carry-in + (2*ar + ab) + (2*br + bb) +; ; = (carry-in + ab + bb) (mod 2) +; ; + 2*(ar + br + (carry-in + ab + bb)/2) +; ; The cases of ar= 0 or br = 0 have already been handled. +; ; So, now we require ar >0 and br>0. That implies that rr>0. +; (relation (carry-in ab ar bb br rb rr) +; (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr)) +; (all +; (pos ar) (pos br) (pos rr) +; (_exists (carry-out) +; (all +; (half-adder carry-in ab bb rb carry-out) +; (full-adder carry-out ar br rr)))) +; ))) + +; After we have checked that both summands have some bits, and so we +; can decompose them the least-significant bit and the other ones, it appears +; we only need to consider the general case, the last relation in +; the code above. +; But that is not sufficient. Let's consider +; (full-adder 0 (1 . ()) (1 0 . ()) (0 1 . ())) +; It would then hold. But it shouldn't, because (1 0 . ()) is a bad +; number (with the most-significant bit 0). One can say why we should +; care about user supplying bad numbers. But we do: we don't know which +; arguments of full-adder are definite numbers and which are +; uninstantiated variables. We don't know which are the input and which +; are the output. So, if we keep only the last relation for the +; case of positive summands, and try to +; (_exists (x) (full-adder 0 (1 . ()) x (0 1 . ()))) +; we will see x bound to (1 0) -- an invalid number. So, our adder, when +; asked to subtract numbers, gave a bad number. And it would give us +; a bad number in all the cases when we use it to subtract numbers and +; the result has fewer bits than the number to subtract from. +; +; To guard against such a behavior (i.e., to transparently normalize +; the numbers when the full-adder is used in the ``subtraction'' mode) +; we have to specifically distinguish cases of +; "bit0 + 2*bit_others" where bit_others>0, and the +; terminal case "1" (that is, the most significant bit 1 and no other +; bits). +; The various (pos ...) conditions in the code are to guarantee that all +; cases are disjoin. At any time, only one case can match. Incidentally, +; the lack of overlap guarantees the optimality of the code. + + +; The full-adder above is not recursively enumerating however. +; Indeed, (solve 10 (x y z) (full-adder '0 x y z)) +; gives solutions with x = 1. +; We now convert the adder into a recursively enumerable form. +; We lose some performance however (but see below!) +; +; The general principles are: +; Convert the relation into a disjunctive normal form, that is +; (any (all a b c) (all c d e) ...) +; and then replace the single, top-level any with any-interleave. +; The conversion may be too invasive. We, therefore, use an effective +; conversion: if we have a relation +; (all (any a b) (any c d)) +; then rather than re-writing it into +; (any (all a c) (all a d) (all b c) (all b d)) +; to push disjunctions out and conjunctions in, we do +; (all gen (all (any a b) (any c d))) +; where gen is a relation whose answer set is precisely such +; that each answer in gen makes (all (any a b) (any c d)) +; semi-deterministic. That is, with the generator gen, we +; make all the further choices determined. +; +; In the code below we use a different kind of generator, whose full +; justification (with proofs) appears in the Prolog version of the code. +; Please see the predicate `enum' in that Prolog code. +; +; The price to pay is slow-down. +; Note, if we had all-interleave, then we would generally have +; breadth-first search and so the changes to the recursively enumerable +; version would be minimal and without loss of speed. + +; The following full-adder* is almost the same as full-adder above. +; +; (define full-adder* +; (extend-relation (carry-in a b r) +; ; (fact (a) 0 a '() a) ; 0 + a + 0 = a +; ; (relation (b) ; 0 + 0 + b = b +; ; (to-show 0 '() b b) +; ; (pos b)) +; ; (relation (head-let '1 a '() r) ; 1 + a + 0 = 0 + a + 1 +; ; (full-adder 0 a '(1) r)) +; ; (relation (head-let '1 '() b r) ; 1 + 0 + b = 0 + 1 + b +; ; (all (pos b) +; ; (full-adder 0 '(1) b r))) +; +; ; The following three relations are needed +; ; to make all numbers well-formed by construction, +; ; that is, to make sure the higher-order bit is one. +; (relation (head-let carry-in '(1) '(1) r) ; c + 1 + 1 >= 2 +; (_exists (r1 r2) +; (all (== r `(,r1 ,r2)) +; (half-adder carry-in 1 1 r1 r2)))) +; +; ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0 +; (relation (carry-in bb br rb rr) +; (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr)) +; (all +; (pos br) (pos rr) +; (_exists (carry-out) +; (all +; (half-adder carry-in 1 bb rb carry-out) +; (full-adder carry-out '() br rr))))) +; +; ; symmetric case for the above +; (relation (head-let carry-in a '(1) r) +; (all +; (gt1 a) (gt1 r) +; (full-adder* carry-in '(1) a r))) +; +; ; carry-in + (2*ar + ab) + (2*br + bb) +; ; = (carry-in + ab + bb) (mod 2) +; ; + 2*(ar + br + (carry-in + ab + bb)/2) +; ; The cases of ar= 0 or br = 0 have already been handled. +; ; So, now we require ar >0 and br>0. That implies that rr>0. +; (relation (carry-in ab ar bb br rb rr) +; (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr)) +; (all +; (pos ar) (pos br) (pos rr) +; (_exists (carry-out) +; (all +; (half-adder carry-in ab bb rb carry-out) +; (full-adder* carry-out ar br rr)))) +; ))) + +; This driver handles the trivial cases and then invokes full-adder* +; coupled with the recursively enumerating generator. + +; (define full-adder +; (extend-relation (carry-in a b r) +; (fact (a) 0 a '() a) ; 0 + a + 0 = a +; (relation (b) ; 0 + 0 + b = b +; (to-show 0 '() b b) +; (pos b)) +; (relation (head-let '1 a '() r) ; 1 + a + 0 = 0 + a + 1 +; (full-adder 0 a '(1) r)) +; (relation (head-let '1 '() b r) ; 1 + 0 + b = 0 + 1 + b +; (all (pos b) +; (full-adder 0 '(1) b r))) +; (relation (head-let carry-in a b r) +; (any-interleave +; ; Note that we take advantage of the fact that if +; ; a + b = r and length(b) <= length(a) then length(a) <= length(r) +; (all (
        = 2 + (_exists (r1 r2) + (all (== r `(,r1 ,r2)) + (half-adder carry-in 1 1 r1 r2)))) + + ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0 + (relation (carry-in bb br rb rr) + (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr)) + (all + (pos br) (pos rr) + (_exists (carry-out) + (all-interleave + (half-adder carry-in 1 bb rb carry-out) + (full-adder carry-out '() br rr))))) + + ; symmetric case for the above + (relation (head-let carry-in a '(1) r) + (all + (gt1 a) (gt1 r) + (full-adder carry-in '(1) a r))) + + ; carry-in + (2*ar + ab) + (2*br + bb) + ; = (carry-in + ab + bb) (mod 2) + ; + 2*(ar + br + (carry-in + ab + bb)/2) + ; The cases of ar= 0 or br = 0 have already been handled. + ; So, now we require ar >0 and br>0. That implies that rr>0. + (relation (carry-in ab ar bb br rb rr) + (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr)) + (all + (pos ar) (pos br) (pos rr) + (_exists (carry-out) + (all-interleave + (half-adder carry-in ab bb rb carry-out) + (full-adder carry-out ar br rr)))) + ))) + +; a + b = c +(define a++o + (relation (head-let a b c) + (full-adder 0 a b c))) + +; a - b = c +(define a--o + (lambda (x y out) + (a++o y out x))) + + +;(define 0 such that n + x = m +; (relation (head-let n m) +; (_exists (x) (all (pos x) (a++o n x m))))) + +; The following is an optimization: it is easier to test for the +; length of two numbers. If one number has fewer bits than the other number, +; the former is clearly shorter (provided that the numbers are well-formed, +; that is, the higher-order bit is one). So we don't need to go through +; the trouble of subtracting them. +(define 0 such that n + x = m + (relation (head-let n m) + (any-interleave + (
          1 + + ; (2*nr) * m = 2*(nr*m), m>0 (the case of m=0 is taken care of already) + ; nr > 0, otherwise the number is ill-formed + (_exists (nr pr) + (all + (gt1 m) + (== n `(0 . ,nr)) + (== p `(0 . ,pr)) + (pos nr) (pos pr) + (**o nr m pr))) + + ; The symmetric case to the above: m is even, n is odd + (_exists (mr pr) + (all + (== n `(1 ,__ . ,__)) ; n is odd and n > 1 + (== m `(0 . ,mr)) + (== p `(0 . ,pr)) + (pos mr) (pos pr) + (**o n mr pr))) + + ; (2*nr+1) * m = 2*(n*m) + m + ; m > 0; also nr>0 for well-formedness + ; the result is certainly greater than 1. + ; we note that m > 0 and so 2*(nr*m) < 2*(nr*m) + m + ; and (floor (log2 (nr*m))) < (floor (log2 (2*(nr*m) + m))) + (_exists (nr p1) + (all + (== m `(1 ,__ . ,__)) ; m is odd and n > 1 + (== n `(1 . ,nr)) + (pos nr) (gt1 p) + (0, so q*m <= n, +; (_exists (p) ; definitely q*m < 2*n +; (all ( (n - r) is even and (n-r)/2 = m*q +; ; (_exists (p m1) +; ; (all (== m `(0 . ,m1)) +; ; (== m1 `(__, . ,__)) +; ; (**o m1 q p) +; ; (a--o n r `(0 . ,p)))) +; + +; A faster and more refutationally complete divo algorithm +; Again, divo n m q r +; holds iff n = m*q + r +; Let l be the bit-length of r (if r=0, l=0). +; Let n = 2^(l+1) * n1 + n2 +; q = 2^(l+1) * q1 + q2 +; Note that n1 or q1 may be zero. +; We obtain that +; n = m*q + r +; is equivalent to the conjunction of the following two relations +; q2*m + r - n2 is divisible by 2^(l+1) +; n1 = q1*m + (q2*m + r - n2)/2^(l+1) +; We note that by construction (see the mentioning of (
            0) and q2*m + r = n2. The latter can be solved in finite +; time. +; We also note that (q2*m + r - n2)/2^(l+1) < m +; because r - n2 < (2^(l+1) - q2)* m +; because 2^(l+1) - q2 >=1 and m > r by construction. Therefore, to +; solve the relation n1 = q1*m + (q2*m + r - n2)/2^(l+1) we use +; divo itself: (divo n1 m q1 (q2*m + r - n2)/2^(l+1)) +; Thus our division algorithm is recursive. On each stage we determine at +; least one bit of the quotient (if r=0, l=0 and q2 is either 0 or 1), +; in finite time. + +(define divo + (relation (head-let n m q r) + (any-interleave + ; m has more digits than n: q=0,n=r + (all (== r n) (== q '()) (= b^q, n < b^(q+1) = b^q * b = (n-r)* b +; r*b < n*(b-1) +; +; We can also obtain the bounds on q: +; if |b| is the bitwidth of b and |n| is the bitwidth of n, +; we have, by the definition of the bitwidth: +; (1) 2^(|b|-1) <= b < 2^|b| +; (2) 2^(|n|-1) <= n < 2^|n| +; Raising (1) to the power of q: +; 2^((|b|-1)*q) <= b^q +; OTH, b^q <= n, and n < 2^|n|. So we obtain +; (3) (|b|-1)*q < |n| +; which defines the upper bound on |q|. +; OTH, raising (1) to the power of (q+1): +; b^(q+1) < 2^(|b|*(q+1)) +; But n < b^(q+1) by definition of exponentiation, and keeping in mind (1) +; (4) |n|-1 < |b|*(q+1) +; which is the lower bound on q. + +; When b = 2, exponentiation and discrete logarithm are easier to obtain +; n = 2^q + r, 0<= 2*r < n +; Here, we just relate n and q. +; exp2 n b q +; holds if: n = (|b|+1)^q + r, q is the largest such number, and +; (|b|+1) is a power of two. +; Side condition: (|b|+1) is a power of two and b is L-instantiated. +; To obtain the binary exp/log relation, invoke the relation as +; (exp2 n '() q) +; Properties: if n is L-instantiated, one answer, q is fully instantiated. +; If q is fully instantiated: one answer, n is L-instantiated. +; In any event, q is always fully instantiated in any answer +; and n is L-instantiated. +; We depend on the properties of split. + +(define exp2 + (letrec + ((r-append ; relational append + (extend-relation (a b c) + (fact (b) '() b b) + (relation (ah ar b cr) (to-show `(,ah . ,ar) b `(,ah . ,cr)) + (r-append ar b cr))))) + (relation (head-let n b q) + (any-interleave + (all (== n '(1)) (== q '())) ; 1 = b^0 + (all (gt1 n) (== q '(1)) (split n b '(1) __)) + (_exists (q1 b2) ; n = (2^k)^(2*q) + r + (all-interleave ; = (2^(2*k))^q + r + (== q `(0 . ,q1)) + (pos q1) + (
              0 + (all (== q '()) (0 + (all (== b '()) (pos q) (== r n)) ; n = 0^q + n, q>0 + ; in the rest, n is longer than b + (all (== b '(0 1)) ; b = 2 + (_exists (n1) + (all + (pos n1) + (== n `(,__ ,__ . ,n1)) ; n is at least 4 + (exp2 n '() q) ; that will L-instantiate n and n1 + (split n n1 __ r)))) + ; the general case + (all + (any (== b '(1 1)) (== b `(,__ ,__ ,__ . ,__))) ; b >= 3 + (
                0! + ((x.0 (0 _.0 . _.1)) (y.0 (1 _.0 . _.1))) + ((x.0 (1 1)) (y.0 (0 0 1))) + ((x.0 (1 0 _.0 . _.1)) (y.0 (0 1 _.0 . _.1)))) +) + +; check that add(X,Y,Z) recursively enumerates all +; numbers such as X+Y=Z +; +(cout "Test recursive enumerability of addition" nl) +(let ((n 7)) + (do ((i 0 (+ 1 i))) ((> i n)) + (do ((j 0 (+ 1 j))) ((> j n)) + (let ((p (+ i j))) + (test-check + (string-append "enumerability: " (number->string i) + "+" (number->string j) "=" (number->string p)) + (solve 1 (x y z) + (all (a++o x y z) + (== x (build i)) (== y (build j)) (== z (build p)))) + `(((x.0 ,(build i)) (y.0 ,(build j)) + (z.0 ,(build p))))))))) + +(test-check "strong commutativity" + (solve 5 (a b c) + (all (a++o a b c) + (_exists (x y z) + (all! + (a++o x y z) + (== x b) + (== y a) + (== z c) + )))) + '(((a.0 ()) (b.0 ()) (c.0 ())) + ((a.0 ()) (b.0 (_.0 . _.1)) (c.0 (_.0 . _.1))) + ((a.0 (1)) (b.0 (1)) (c.0 (0 1))) + ((a.0 (1)) (b.0 (0 _.0 . _.1)) (c.0 (1 _.0 . _.1))) + ((a.0 (0 _.0 . _.1)) (b.0 (1)) (c.0 (1 _.0 . _.1)))) +) + + +(cout nl "subtraction" nl) +(test (x) (a--o (build 29) (build 3) x)) +(test (x) (a--o (build 29) x (build 3))) +(test (x) (a--o x (build 3) (build 26))) +(test (x) (a--o (build 29) (build 29) x)) +(test (x) (a--o (build 29) (build 30) x)) +(test-check "print a few numbers such as Y - Z = 4" + (solve 11 (y z) (a--o y z (build 4))) + '(((y.0 (0 0 1)) (z.0 ())) ; 4 - 0 = 4 + ((y.0 (1 0 1)) (z.0 (1))) ; 5 - 1 = 4 + ((y.0 (0 1 1)) (z.0 (0 1))) ; 6 - 2 = 4 + ((y.0 (1 1 1)) (z.0 (1 1))) ; 7 - 3 = 4 + ((y.0 (0 0 0 1)) (z.0 (0 0 1))) ; 8 - 4 = 4 + ((y.0 (1 0 0 1)) (z.0 (1 0 1))) ; 9 - 5 = 4 + ((y.0 (0 1 0 1)) (z.0 (0 1 1))) ; 10 - 6 = 4 + ((y.0 (1 1 0 1)) (z.0 (1 1 1))) ; 11 - 7 = 4 + ; 8*k + 4 - 8*k = 4 forall k> 0!! + ((y.0 (0 0 1 _.0 . _.1)) (z.0 (0 0 0 _.0 . _.1))) + ((y.0 (1 0 1 _.0 . _.1)) (z.0 (1 0 0 _.0 . _.1))) + ((y.0 (0 1 1 _.0 . _.1)) (z.0 (0 1 0 _.0 . _.1)))) +) + +(test-check "print a few numbers such as X - Y = Z" + (solve 5 (x y z) (a--o x y z)) + '(((x.0 _.0) (y.0 _.0) (z.0 ())) ; 0 - 0 = 0 + ((x.0 (_.0 . _.1)) (y.0 ()) (z.0 (_.0 . _.1))) ; a - 0 = a + ((x.0 (0 1)) (y.0 (1)) (z.0 (1))) + ((x.0 (1 _.0 . _.1)) (y.0 (1)) (z.0 (0 _.0 . _.1))) + ((x.0 (1 _.0 . _.1)) (y.0 (0 _.0 . _.1)) (z.0 (1)))) +) + + +(cout nl "comparisons" nl) +(test (x) ( 0 + ; 1 * y = y for y > 0 + ((x.0 (1)) (y.0 (_.0 . _.1)) (z.0 (_.0 . _.1))) + ((x.0 (_.0 _.1 . _.2)) (y.0 (1)) + (z.0 (_.0 _.1 . _.2))) ; x * 1 = x, x > 1 + ; 2 * y = even positive number, for y > 1 + ((x.0 (0 1)) (y.0 (_.0 _.1 . _.2)) + (z.0 (0 _.0 _.1 . _.2))) + ; x * 2 = shifted-left x, for even x>1 + ((x.0 (1 _.0 . _.1)) (y.0 (0 1)) (z.0 (0 1 _.0 . _.1))) + ; 3 * 3 = 9 + ((x.0 (1 1)) (y.0 (1 1)) (z.0 (1 0 0 1))) + ) +) + +(test-check 'multiplication-even-1 + (solve 10 (y z) (**o (build 2) y z)) + '(((y.0 ()) (z.0 ())) + ((y.0 (1)) (z.0 (0 1))) ; 2 * 1 = 2 + ; 2*y is an even number, for any y > 1! + ((y.0 (_.0 _.1 . _.2)) (z.0 (0 _.0 _.1 . _.2))) + ) +) + +(test-check 'multiplication-even-2 + ; multiplication by an even number cannot yield an odd number + (solution (q x y u v) (**o '(1 1) `(0 0 1 ,x . ,y) `(1 0 0 ,u . ,v))) + #f +) + +(test-check 'multiplication-even-3 + ; multiplication by an even number cannot yield an odd number + (solution (q x y z) (**o `(0 0 1 . ,y) `(1 . ,x) `(1 0 . ,z))) + #f +) + +; check that mul(X,Y,Z) recursively enumerates all +; numbers such as X*Y=Z +; +(cout "Test recursive enumerability of multiplication" nl) +(let ((n 7)) + (do ((i 0 (+ 1 i))) ((> i n)) + (do ((j 0 (+ 1 j))) ((> j n)) + (let ((p (* i j))) + (test-check + (string-append "enumerability: " (number->string i) + "*" (number->string j) "=" (number->string p)) + (solve 1 (x y z) + (all (**o x y z) + (== x (build i)) (== y (build j)) (== z (build p)))) + `(((x.0 ,(build i)) (y.0 ,(build j)) + (z.0 ,(build p))))))))) + +(cout nl "split" nl) + +(test-check 'split-1 + (solve 5 (x y) (split (build 4) '() x y)) + '(((x.0 (0 1)) (y.0 ())))) +(test-check 'split-2 + (solve 5 (x y) (split (build 4) '(1) x y)) + '(((x.0 (1)) (y.0 ())))) +(test-check 'split-3 + (solve 5 (x y) (split (build 4) '(1 1) x y)) + '(((x.0 ()) (y.0 (0 0 1))))) +(test-check 'split-4 + (solve 5 (x y) (split (build 4) '(1 1 1) x y)) + '(((x.0 ()) (y.0 (0 0 1))))) +(test-check 'split-5 + (solve 5 (x y) (split (build 5) '(1) x y)) + '(((x.0 (1)) (y.0 (1))))) +(test-check 'split-6 + (solve 5 (n) (split n (build 5) '() '(1))) + '(((n.0 (1))))) + +(cout nl "division, general" nl) + + +(test-check 'divo-1 + (solution (x) (divo (build 4) (build 2) x __)) + '((x.0 (0 1)))) +(test-check 'div-fail-1 (test (x) (divo (build 4) (build 0) x __)) '()) +(test-check 'divo-2 + (solution (x) (divo (build 4) (build 3) x __)) + '((x.0 (1)))) +(test-check 'divo-3 + (solution (x) (divo (build 4) (build 4) x __)) + '((x.0 (1)))) +(test-check 'divo-4 + (solution (x y) (divo (build 4) (build 5) x y)) + '((x.0 ()) (y.0 (0 0 1)))) + + +(test-check 'divo-33-1 + (solution (x) (divo (build 33) (build 3) x __)) + `((x.0 ,(build 11)))) +(test-check 'divo-33-2 + (solution (x) (divo (build 33) x (build 11) __)) + `((x.0 ,(build 3)))) +(test-check 'divo-33-3 + (solution (x) (divo x (build 3) (build 11) __)) + `((x.0 ,(build 33)))) +(test-check 'divo-33-5 + (solution (x y) (divo (build 33) (build 5) x y)) + `((x.0 ,(build 6)) (y.0 ,(build 3)))) + + +(test-check 'divo-5-4 + (solve 3 (x y) (divo x (build 5) y (build 4))) + '(((x.0 (0 0 1)) (y.0 ())) + ((x.0 (0 0 0 0 0 0 1)) (y.0 (0 0 1 1))) + ((x.0 (1 0 0 0 1 1)) (y.0 (1 0 0 1)))) +) +(test-check 'divo-5-5 + (solve 3 (x y) (divo x (build 5) y (build 5))) + '()) + + +(test (x) (divo x (build 5) __ (build 4))) +(test (x) (divo x (build 5) (build 3) (build 4))) +(test (x) (divo x __ (build 3) (build 4))) +(test-check 'div-fail-2 (test (x) (divo (build 5) x (build 7) __)) '()) + +(test-check "all numbers such as 5/Z = 1" + (solve 7 (w) + (_exists (z) (all (divo (build 5) z (build 1) __) + (project (z) (== `(,(trans z)) w))))) + '(((w.0 (5))) ((w.0 (3))) ((w.0 (4))))) + +(test-check "all inexact factorizations of 12" + (set-equal? + (solve 100 (w) + (_exists (m q r n) + (all + (== n (build 12)) + (0 + ((x.0 (1)) (y.0 (1)) (z.0 (1)) (r.0 ())) ; 1 = 1*1 + 0 + ((x.0 (0 1)) (y.0 (1)) (z.0 (0 1)) (r.0 ())) ; 2 = 1*2 + 0 + ((x.0 (0 1)) (y.0 (1 1)) (z.0 ()) (r.0 (0 1))) ; 2 = 3*0 + 2 +)) + +(test-check 'div-even + (solve 3 (y z r) (divo `(0 . ,y) (build 2) z r)) + '(((y.0 (1)) (z.0 (1)) (r.0 ())) + ((y.0 (0 1)) (z.0 (0 1)) (r.0 ())) + ((y.0 (1 1)) (z.0 (1 1)) (r.0 ()))) +) + +(test-check 'div-even-fail + (solve 3 (y z r) (divo `(0 . ,y) (build 2) z '(1))) + '() +) + +(test-check 'div-odd + (solve 3 (y z) (divo `(1 0 . ,y) (build 2) z '(1))) + '(((y.0 (0 1)) (z.0 (0 0 1))) ; 9 = 2*4 + 1 + ((y.0 (1)) (z.0 (0 1))) ; 5 = 2*2 + 1 + ((y.0 (0 0 1)) (z.0 (0 0 0 1)))) ; 17 = 8*2 + 1 +) + +(test-check 'div-odd-fail + (solve 3 (y z r) (divo `(1 0 . ,y) (build 2) z '())) + '() +) + +(test-check 'div-enum-sample + (solve 1 (n m q r) + (all (divo n m q r) + (== n (build 10)) (== m (build 2)) (== q (build 5)) + (== r '()))) + '(((n.0 (0 1 0 1)) (m.0 (0 1)) (q.0 (1 0 1)) (r.0 ()))) +) + +; the latter takes awfully long time +'(test-check 'div-enum-sample-1 + (solve 1 (n m q r) + (all (divo n m q r) + (== n (build 10)) (== m (build 3)) (== q (build 3)) + (== r '(1)))) + '(((n.0 (1 1 1)) (m.0 (0 1)) (q.0 (1 1)) (r.0 (1)))) +) + +; check that divo(N,M,Q,R) recursively enumerates all +; numbers such as N=M*Q+R, R m n)) + (do ((q 0 (+ 1 q))) ((> q n)) + (do ((r 0 (+ 1 r))) ((>= r m)) + (let ((n (+ (* m q) r))) + (test-check + (string-append "enumerability: " (number->string n) + "=" (number->string m) "*" (number->string q) + "+" (number->string r)) + (solve 1 (n1 m1 q1 r1) + (all (divo n1 m1 q1 r1) + (== n1 (build n)) (== m1 (build m)) + (== q1 (build q)) (== r1 (build r)) + )) + `(((n1.0 ,(build n)) (m1.0 ,(build m)) + (q1.0 ,(build q)) (r1.0 ,(build r)))))))))) + + +; quite dubious tests. The problem is actually in =ol and
                  elements car) + +(define lattice->cmp cdr) + +; Select elements of a list which pass some test. +(define zulu-select + (lambda (test lst) + (define select-a + (lambda (ac lst) + (if (null? lst) + (reverse! ac) + (select-a + (let ((head (car lst))) + (if (test head) + (cons head ac) + ac)) + (cdr lst))))) + (select-a '() lst))) + +(define reverse! + (letrec ((rotate + (lambda (fo fum) + (let ((next (cdr fo))) + (set-cdr! fo fum) + (if (null? next) + fo + (rotate next fo)))))) + (lambda (lst) + (if (null? lst) + '() + (rotate lst '()))))) + +; Select elements of a list which pass some test and map a function +; over the result. Note, only efficiency prevents this from being the +; composition of select and map. +(define select-map + (lambda (test func lst) + (define select-a + (lambda (ac lst) + (if (null? lst) + (reverse! ac) + (select-a + (let ((head (car lst))) + (if (test head) + (cons (func head) + ac) + ac)) + (cdr lst))))) + (select-a '() lst))) + + + +; This version of map-and tail-recurses on the last test. +(define map-and + (lambda (proc lst) + (if (null? lst) + #t + (letrec ((drudge + (lambda (lst) + (let ((rest (cdr lst))) + (if (null? rest) + (proc (car lst)) + (and (proc (car lst)) + (drudge rest))))))) + (drudge lst))))) + +(define (maps-1 source target pas new) + (let ((scmp (lattice->cmp source)) + (tcmp (lattice->cmp target))) + (let ((less + (select-map + (lambda (p) + (eq? 'less + (scmp (car p) new))) + cdr + pas)) + (more + (select-map + (lambda (p) + (eq? 'more + (scmp (car p) new))) + cdr + pas))) + (zulu-select + (lambda (t) + (and + (map-and + (lambda (t2) + (memq (tcmp t2 t) '(less equal))) + less) + (map-and + (lambda (t2) + (memq (tcmp t2 t) '(more equal))) + more))) + (lattice->elements target))))) + +(define (maps-rest source target pas rest to-1 to-collect) + (if (null? rest) + (to-1 pas) + (let ((next (car rest)) + (rest (cdr rest))) + (to-collect + (map + (lambda (x) + (maps-rest source target + (cons + (cons next x) + pas) + rest + to-1 + to-collect)) + (maps-1 source target pas next)))))) + +(define (maps source target) + (make-lattice + (maps-rest source + target + '() + (lattice->elements source) + (lambda (x) (list (map cdr x))) + (lambda (x) (apply append x))) + (lexico (lattice->cmp target)))) + +(define (count-maps source target) + (maps-rest source + target + '() + (lattice->elements source) + (lambda (x) 1) + sum)) + +(define (sum lst) + (if (null? lst) + 0 + (+ (car lst) (sum (cdr lst))))) + +(define (run) + (let* ((l2 + (make-lattice '(low high) + (lambda (lhs rhs) + (case lhs + ((low) + (case rhs + ((low) + 'equal) + ((high) + 'less) + (else + (error 'make-lattice "base" rhs)))) + ((high) + (case rhs + ((low) + 'more) + ((high) + 'equal) + (else + (error 'make-lattice "base" rhs)))) + (else + (error 'make-lattice "base" lhs)))))) + (l3 (maps l2 l2)) + (l4 (maps l3 l3))) + (count-maps l2 l2) + (count-maps l3 l3) + (count-maps l2 l3) + (count-maps l3 l2) + (count-maps l4 l4))) + +(time (run)) diff --git a/benchmarks/gabriel/lattice2.sch b/benchmarks/gabriel/lattice2.sch new file mode 100644 index 00000000..482ed678 --- /dev/null +++ b/benchmarks/gabriel/lattice2.sch @@ -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)) diff --git a/benchmarks/gabriel/maze.sch b/benchmarks/gabriel/maze.sch new file mode 100644 index 00000000..e56bf17a --- /dev/null +++ b/benchmarks/gabriel/maze.sch @@ -0,0 +1,680 @@ +;;; MAZE -- Constructs a maze on a hexagonal grid, written by Olin Shivers. + +;------------------------------------------------------------------------------ +; Was file "rand.scm". + +; Minimal Standard Random Number Generator +; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version. +; better constants, as proposed by Park. +; By Ozan Yigit + +;;; Rehacked by Olin 4/1995. + +(define (random-state n) + (cons n #f)) + +(define (rand state) + (let ((seed (car state)) + (A 2813) ; 48271 + (M 8388607) ; 2147483647 + (Q 2787) ; 44488 + (R 2699)) ; 3399 + (let* ((hi (quotient seed Q)) + (lo (modulo seed Q)) + (test (- (* A lo) (* R hi))) + (val (if (> test 0) test (+ test M)))) + (set-car! state val) + val))) + +(define (random-int n state) + (modulo (rand state) n)) + +; poker test +; seed 1 +; cards 0-9 inclusive (random 10) +; five cards per hand +; 10000 hands +; +; Poker Hand Example Probability Calculated +; 5 of a kind (aaaaa) 0.0001 0 +; 4 of a kind (aaaab) 0.0045 0.0053 +; Full house (aaabb) 0.009 0.0093 +; 3 of a kind (aaabc) 0.072 0.0682 +; two pairs (aabbc) 0.108 0.1104 +; Pair (aabcd) 0.504 0.501 +; Bust (abcde) 0.3024 0.3058 + +; (define (random n) +; (let* ((M 2147483647) +; (slop (modulo M n))) +; (let loop ((r (rand))) +; (if (> r slop) +; (modulo r n) +; (loop (rand)))))) +; +; (define (rngtest) +; (display "implementation ") +; (srand 1) +; (let loop ((n 0)) +; (if (< n 10000) +; (begin +; (rand) +; (loop (1+ n))))) +; (if (= *seed* 399268537) +; (display "looks correct.") +; (begin +; (display "failed.") +; (newline) +; (display " current seed ") (display *seed*) +; (newline) +; (display " correct seed 399268537"))) +; (newline)) + +;------------------------------------------------------------------------------ +; Was file "uf.scm". + +;;; Tarjan's amortised union-find data structure. +;;; Copyright (c) 1995 by Olin Shivers. + +;;; This data structure implements disjoint sets of elements. +;;; Four operations are supported. The implementation is extremely +;;; fast -- any sequence of N operations can be performed in time +;;; so close to linear it's laughable how close it is. See your +;;; intro data structures book for more. The operations are: +;;; +;;; - (base-set nelts) -> set +;;; Returns a new set, of size NELTS. +;;; +;;; - (set-size s) -> integer +;;; Returns the number of elements in set S. +;;; +;;; - (union! set1 set2) +;;; Unions the two sets -- SET1 and SET2 are now considered the same set +;;; by SET-EQUAL?. +;;; +;;; - (set-equal? set1 set2) +;;; Returns true <==> the two sets are the same. + +;;; Representation: a set is a cons cell. Every set has a "representative" +;;; cons cell, reached by chasing cdr links until we find the cons with +;;; cdr = (). Set equality is determined by comparing representatives using +;;; EQ?. A representative's car contains the number of elements in the set. + +;;; The speed of the algorithm comes because when we chase links to find +;;; representatives, we collapse links by changing all the cells in the path +;;; we followed to point directly to the representative, so that next time +;;; we walk the cdr-chain, we'll go directly to the representative in one hop. + + +(define (base-set nelts) (cons nelts '())) + +;;; Sets are chained together through cdr links. Last guy in the chain +;;; is the root of the set. + +(define (get-set-root s) + (let lp ((r s)) ; Find the last pair + (let ((next (cdr r))) ; in the list. That's + (cond ((pair? next) (lp next)) ; the root r. + + (else + (if (not (eq? r s)) ; Now zip down the list again, + (let lp ((x s)) ; changing everyone's cdr to r. + (let ((next (cdr x))) + (cond ((not (eq? r next)) + (set-cdr! x r) + (lp next)))))) + r))))) ; Then return r. + +(define (set-equal? s1 s2) (eq? (get-set-root s1) (get-set-root s2))) + +(define (set-size s) (car (get-set-root s))) + +(define (union! s1 s2) + (let* ((r1 (get-set-root s1)) + (r2 (get-set-root s2)) + (n1 (set-size r1)) + (n2 (set-size r2)) + (n (+ n1 n2))) + + (cond ((> n1 n2) + (set-cdr! r2 r1) + (set-car! r1 n)) + (else + (set-cdr! r1 r2) + (set-car! r2 n))))) + +;------------------------------------------------------------------------------ +; Was file "maze.scm". + +;;; Building mazes with union/find disjoint sets. +;;; Copyright (c) 1995 by Olin Shivers. + +;;; This is the algorithmic core of the maze constructor. +;;; External dependencies: +;;; - RANDOM-INT +;;; - Union/find code +;;; - bitwise logical functions + +; (define-record wall +; owner ; Cell that owns this wall. +; neighbor ; The other cell bordering this wall. +; bit) ; Integer -- a bit identifying this wall in OWNER's cell. + +; (define-record cell +; reachable ; Union/find set -- all reachable cells. +; id ; Identifying info (e.g., the coords of the cell). +; (walls -1) ; A bitset telling which walls are still standing. +; (parent #f) ; For DFS spanning tree construction. +; (mark #f)) ; For marking the solution path. + +(define (make-wall owner neighbor bit) + (vector 'wall owner neighbor bit)) + +(define (wall:owner o) (vector-ref o 1)) +(define (set-wall:owner o v) (vector-set! o 1 v)) +(define (wall:neighbor o) (vector-ref o 2)) +(define (set-wall:neighbor o v) (vector-set! o 2 v)) +(define (wall:bit o) (vector-ref o 3)) +(define (set-wall:bit o v) (vector-set! o 3 v)) + +(define (make-cell reachable id) + (vector 'cell reachable id -1 #f #f)) + +(define (cell:reachable o) (vector-ref o 1)) +(define (set-cell:reachable o v) (vector-set! o 1 v)) +(define (cell:id o) (vector-ref o 2)) +(define (set-cell:id o v) (vector-set! o 2 v)) +(define (cell:walls o) (vector-ref o 3)) +(define (set-cell:walls o v) (vector-set! o 3 v)) +(define (cell:parent o) (vector-ref o 4)) +(define (set-cell:parent o v) (vector-set! o 4 v)) +(define (cell:mark o) (vector-ref o 5)) +(define (set-cell:mark o v) (vector-set! o 5 v)) + +;;; Iterates in reverse order. + +(define (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)))))) diff --git a/benchmarks/gabriel/maze2.sch b/benchmarks/gabriel/maze2.sch new file mode 100644 index 00000000..4a2a9168 --- /dev/null +++ b/benchmarks/gabriel/maze2.sch @@ -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)))))) diff --git a/benchmarks/gabriel/mazefun.sch b/benchmarks/gabriel/mazefun.sch new file mode 100644 index 00000000..bec2f56e --- /dev/null +++ b/benchmarks/gabriel/mazefun.sch @@ -0,0 +1,206 @@ +;;; MAZEFUN -- Constructs a maze in a purely functional way, +;;; written by Marc Feeley. + +(define iota + (lambda (n) + (iota-iter n '()))) + +(define iota-iter + (lambda (n lst) + (if (= n 0) + lst + (iota-iter (- n 1) (cons n lst))))) + +(define foldr + (lambda (f base lst) + + (define foldr-aux + (lambda (lst) + (if (null? lst) + base + (f (car lst) (foldr-aux (cdr lst)))))) + + (foldr-aux lst))) + +(define foldl + (lambda (f base lst) + + (define foldl-aux + (lambda (base lst) + (if (null? lst) + base + (foldl-aux (f base (car lst)) (cdr lst))))) + + (foldl-aux base lst))) + +(define for + (lambda (lo hi f) + + (define for-aux + (lambda (lo) + (if (< lo hi) + (cons (f lo) (for-aux (+ lo 1))) + '()))) + + (for-aux lo))) + +(define concat + (lambda (lists) + (foldr append '() lists))) + +(define list-read + (lambda (lst i) + (if (= i 0) + (car lst) + (list-read (cdr lst) (- i 1))))) + +(define list-write + (lambda (lst i val) + (if (= i 0) + (cons val (cdr lst)) + (cons (car lst) (list-write (cdr lst) (- i 1) val))))) + +(define list-remove-pos + (lambda (lst i) + (if (= i 0) + (cdr lst) + (cons (car lst) (list-remove-pos (cdr lst) (- i 1)))))) + +(define duplicates? + (lambda (lst) + (if (null? lst) + #f + (or (member (car lst) (cdr lst)) + (duplicates? (cdr lst)))))) + +; Manipulation de matrices. + +(define make-matrix + (lambda (n m init) + (for 0 n (lambda (i) (for 0 m (lambda (j) (init i j))))))) + +(define matrix-read + (lambda (mat i j) + (list-read (list-read mat i) j))) + +(define matrix-write + (lambda (mat i j val) + (list-write mat i (list-write (list-read mat i) j val)))) + +(define matrix-size + (lambda (mat) + (cons (length mat) (length (car mat))))) + +(define matrix-map + (lambda (f mat) + (map (lambda (lst) (map f lst)) mat))) + +(define initial-random 0) + +(define next-random + (lambda (current-random) + (remainder (+ (* current-random 3581) 12751) 131072))) + +(define shuffle + (lambda (lst) + (shuffle-aux lst initial-random))) + +(define shuffle-aux + (lambda (lst current-random) + (if (null? lst) + '() + (let ((new-random (next-random current-random))) + (let ((i (modulo new-random (length lst)))) + (cons (list-read lst i) + (shuffle-aux (list-remove-pos lst i) + new-random))))))) + +(define make-maze + (lambda (n m) ; n and m must be odd + (if (not (and (odd? n) (odd? m))) + 'error + (let ((cave + (make-matrix n m (lambda (i j) + (if (and (even? i) (even? j)) + (cons i j) + #f)))) + (possible-holes + (concat + (for 0 n (lambda (i) + (concat + (for 0 m (lambda (j) + (if (equal? (even? i) (even? j)) + '() + (list (cons i j))))))))))) + (cave-to-maze (pierce-randomly (shuffle possible-holes) cave)))))) + +(define cave-to-maze + (lambda (cave) + (matrix-map (lambda (x) (if x '_ '*)) cave))) + +(define pierce + (lambda (pos cave) + (let ((i (car pos)) (j (cdr pos))) + (matrix-write cave i j pos)))) + +(define pierce-randomly + (lambda (possible-holes cave) + (if (null? possible-holes) + cave + (let ((hole (car possible-holes))) + (pierce-randomly (cdr possible-holes) + (try-to-pierce hole cave)))))) + +(define try-to-pierce + (lambda (pos cave) + (let ((i (car pos)) (j (cdr pos))) + (let ((ncs (neighboring-cavities pos cave))) + (if (duplicates? + (map (lambda (nc) (matrix-read cave (car nc) (cdr nc))) ncs)) + cave + (pierce pos + (foldl (lambda (c nc) (change-cavity c nc pos)) + cave + ncs))))))) + +(define change-cavity + (lambda (cave pos new-cavity-id) + (let ((i (car pos)) (j (cdr pos))) + (change-cavity-aux cave pos new-cavity-id (matrix-read cave i j))))) + +(define change-cavity-aux + (lambda (cave pos new-cavity-id old-cavity-id) + (let ((i (car pos)) (j (cdr pos))) + (let ((cavity-id (matrix-read cave i j))) + (if (equal? cavity-id old-cavity-id) + (foldl (lambda (c nc) + (change-cavity-aux c nc new-cavity-id old-cavity-id)) + (matrix-write cave i j new-cavity-id) + (neighboring-cavities pos cave)) + cave))))) + +(define neighboring-cavities + (lambda (pos cave) + (let ((size (matrix-size cave))) + (let ((n (car size)) (m (cdr size))) + (let ((i (car pos)) (j (cdr pos))) + (append (if (and (> i 0) (matrix-read cave (- i 1) j)) + (list (cons (- i 1) j)) + '()) + (if (and (< i (- n 1)) (matrix-read cave (+ i 1) j)) + (list (cons (+ i 1) j)) + '()) + (if (and (> j 0) (matrix-read cave i (- j 1))) + (list (cons i (- j 1))) + '()) + (if (and (< j (- m 1)) (matrix-read cave i (+ j 1))) + (list (cons i (+ j 1))) + '()))))))) + + +(let ((input (with-input-from-file "input.txt" read))) + (time (let loop ((n 500) (v 0)) + (if (zero? n) + v + (loop (- n 1) + (make-maze 11 (if input 11 0))))))) diff --git a/benchmarks/gabriel/nboyer.sch b/benchmarks/gabriel/nboyer.sch new file mode 100644 index 00000000..c7e887a2 --- /dev/null +++ b/benchmarks/gabriel/nboyer.sch @@ -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) + diff --git a/benchmarks/gabriel/nestedloop.sch b/benchmarks/gabriel/nestedloop.sch new file mode 100644 index 00000000..64c6c056 --- /dev/null +++ b/benchmarks/gabriel/nestedloop.sch @@ -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)))) + diff --git a/benchmarks/gabriel/nfa.sch b/benchmarks/gabriel/nfa.sch new file mode 100644 index 00000000..b00dcd07 --- /dev/null +++ b/benchmarks/gabriel/nfa.sch @@ -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))))))) + + + diff --git a/benchmarks/gabriel/nothing.sch b/benchmarks/gabriel/nothing.sch new file mode 100644 index 00000000..d3cd0721 --- /dev/null +++ b/benchmarks/gabriel/nothing.sch @@ -0,0 +1 @@ +(time 1) diff --git a/benchmarks/gabriel/nqueens.sch b/benchmarks/gabriel/nqueens.sch new file mode 100644 index 00000000..26a6f851 --- /dev/null +++ b/benchmarks/gabriel/nqueens.sch @@ -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))))))) diff --git a/benchmarks/gabriel/nucleic2.sch b/benchmarks/gabriel/nucleic2.sch new file mode 100644 index 00000000..4c3c347a --- /dev/null +++ b/benchmarks/gabriel/nucleic2.sch @@ -0,0 +1,3508 @@ +; File: "nucleic2.scm" +; +; Author: Marc Feeley (feeley@iro.umontreal.ca) +; Last modification by Feeley: June 6, 1994. +; Modified for R5RS Scheme by William D Clinger: 22 October 1996. +; Last modification by Clinger: 19 March 1999. +; +; This program is a modified version of the program described in +; +; M. Feeley, M. Turcotte, G. Lapalme. Using Multilisp for Solving +; Constraint Satisfaction Problems: an Application to Nucleic Acid 3D +; Structure Determination. Lisp and Symbolic Computation 7(2/3), +; 231-246, 1994. +; +; The differences between this program and the original are described in +; +; P.H. Hartel, M. Feeley, et al. Benchmarking Implementations of +; Functional Languages with "Pseudoknot", a Float-Intensive Benchmark. +; Journal of Functional Programming 6(4), 621-655, 1996. + +; This procedure uses Marc Feeley's run-benchmark procedure to time +; the benchmark. + +; PORTABILITY. +; +; This program should run in any R5RS-conforming implementation of Scheme. +; To run this program in an implementation that does not support the R5RS +; macro system, however, you will have to place a single quotation mark (') +; on the following line and also modify the "SYSTEM DEPENDENT CODE" below. + +; ********** R5RS Scheme + +(begin + +(define-syntax FLOAT+ (syntax-rules () ((FLOAT+ x ...) (+ x ...)))) +(define-syntax FLOAT- (syntax-rules () ((FLOAT- x ...) (- x ...)))) +(define-syntax FLOAT* (syntax-rules () ((FLOAT* x ...) (* x ...)))) +(define-syntax FLOAT/ (syntax-rules () ((FLOAT/ x ...) (/ x ...)))) +(define-syntax FLOAT= (syntax-rules () ((FLOAT= x y) (= x y)))) +(define-syntax FLOAT< (syntax-rules () ((FLOAT< x y) (< x y)))) +(define-syntax FLOAT<= (syntax-rules () ((FLOAT<= x y) (<= x y)))) +(define-syntax FLOAT> (syntax-rules () ((FLOAT> x y) (> x y)))) +(define-syntax FLOAT>= (syntax-rules () ((FLOAT>= x y) (>= x y)))) +(define-syntax FLOATsin (syntax-rules () ((FLOATsin x) (sin x)))) +(define-syntax FLOATcos (syntax-rules () ((FLOATcos x) (cos x)))) +(define-syntax FLOATatan (syntax-rules () ((FLOATatan x) (atan x)))) +(define-syntax FLOATsqrt (syntax-rules () ((FLOATsqrt x) (sqrt x)))) + +(define-syntax FUTURE (syntax-rules () ((FUTURE x) x))) +(define-syntax TOUCH (syntax-rules () ((TOUCH x) x))) + +(define-syntax define-structure + (syntax-rules () + ((define-structure #f + name make make-constant (select1 ...) (set1 ...)) + (begin (define-syntax make + (syntax-rules () + ((make select1 ...) + (vector select1 ...)))) + (define-syntax make-constant + (syntax-rules () + ; The vectors that are passed to make-constant aren't quoted. + ((make-constant . args) + (constant-maker make . args)))) + (define-selectors (select1 ...) + (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 37 38 39 + 40 41 42 43 44 45 46 47 48 49)) + (define-setters (set1 ...) + (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 37 38 39 + 40 41 42 43 44 45 46 47 48 49)))) + ((define-structure pred? + name make make-constant (select1 ...) (set1 ...)) + (begin (define-syntax pred? + (syntax-rules () + ((pred? v) + (and (vector? v) (eq? (vector-ref v 0) 'name))))) + (define-syntax make + (syntax-rules () + ((make select1 ...) + (vector 'name select1 ...)))) + (define-syntax make-constant + (syntax-rules () + ; The vectors that are passed to make-constant aren't quoted. + ((make-constant . args) + (constant-maker make . args)))) + (define-selectors (select1 ...) + (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 37 38 39 + 40 41 42 43 44 45 46 47 48 49)) + (define-setters (set1 ...) + (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 37 38 39 + 40 41 42 43 44 45 46 47 48 49)))))) +(define-syntax constant-maker + (syntax-rules () + ; The quotation marks are added here. + ((constant-maker make arg ...) + (make 'arg ...)))) +(define-syntax define-selectors + (syntax-rules () + ((define-selectors (select) (i i1 ...)) + (define-syntax select + (syntax-rules () + ((select v) (vector-ref v i))))) + ((define-selectors (select select1 ...) (i i1 ...)) + (begin (define-syntax select + (syntax-rules () + ((select v) (vector-ref v i)))) + (define-selectors (select1 ...) (i1 ...)))))) +(define-syntax define-setters + (syntax-rules () + ((define-setters (set) (i i1 ...)) + (define-syntax set + (syntax-rules () + ((set v x) (vector-set! v i x))))) + ((define-setters (set set1 ...) (i i1 ...)) + (begin (define-syntax set + (syntax-rules () + ((set v x) (vector-set! v i x)))) + (define-setters (set1 ...) (i1 ...)))))) + +(define-structure #f pt + make-pt make-constant-pt + (pt-x pt-y pt-z) + (pt-x-set! pt-y-set! pt-z-set!)) + +(define-structure #f tfo + make-tfo make-constant-tfo + (tfo-a tfo-b tfo-c tfo-d tfo-e tfo-f tfo-g tfo-h tfo-i tfo-tx tfo-ty tfo-tz) + (tfo-a-set! tfo-b-set! tfo-c-set! tfo-d-set! tfo-e-set! tfo-f-set! + tfo-g-set! tfo-h-set! tfo-i-set! tfo-tx-set! tfo-ty-set! tfo-tz-set!)) + +(define-structure nuc? nuc + make-nuc make-constant-nuc + (nuc-dgf-base-tfo ; defines the standard position for wc and wc-dumas + nuc-P-O3*-275-tfo ; defines the standard position for the connect function + nuc-P-O3*-180-tfo + nuc-P-O3*-60-tfo + nuc-P nuc-O1P nuc-O2P nuc-O5* nuc-C5* + nuc-H5* nuc-H5** + nuc-C4* nuc-H4* nuc-O4* nuc-C1* nuc-H1* + nuc-C2* nuc-H2** + nuc-O2* nuc-H2* nuc-C3* nuc-H3* nuc-O3* + nuc-N1 nuc-N3 nuc-C2 nuc-C4 nuc-C5 nuc-C6) + (nuc-dgf-base-tfo-set! + nuc-P-O3*-275-tfo-set! + nuc-P-O3*-180-tfo-set! + nuc-P-O3*-60-tfo-set! + nuc-P-set! nuc-O1P-set! nuc-O2P-set! nuc-O5*-set! nuc-C5*-set! + nuc-H5*-set! nuc-H5**-set! + nuc-C4*-set! nuc-H4*-set! nuc-O4*-set! nuc-C1*-set! nuc-H1*-set! + nuc-C2*-set! nuc-H2**-set! + nuc-O2*-set! nuc-H2*-set! nuc-C3*-set! nuc-H3*-set! nuc-O3*-set! + nuc-N1-set! nuc-N3-set! nuc-C2-set! nuc-C4-set! nuc-C5-set! nuc-C6-set!)) + +(define-structure rA? rA + make-rA make-constant-rA + (rA-dgf-base-tfo ; defines the standard position for wc and wc-dumas + rA-P-O3*-275-tfo ; defines the standard position for the connect function + rA-P-O3*-180-tfo + rA-P-O3*-60-tfo + rA-P rA-O1P rA-O2P rA-O5* rA-C5* + rA-H5* rA-H5** + rA-C4* rA-H4* rA-O4* rA-C1* rA-H1* + rA-C2* rA-H2** + rA-O2* rA-H2* rA-C3* rA-H3* rA-O3* + rA-N1 rA-N3 rA-C2 rA-C4 rA-C5 rA-C6 + rA-N6 rA-N7 rA-N9 rA-C8 + rA-H2 rA-H61 rA-H62 rA-H8) + (rA-dgf-base-tfo-set! + rA-P-O3*-275-tfo-set! + rA-P-O3*-180-tfo-set! + rA-P-O3*-60-tfo-set! + rA-P-set! rA-O1P-set! rA-O2P-set! rA-O5*-set! rA-C5*-set! + rA-H5*-set! rA-H5**-set! + rA-C4*-set! rA-H4*-set! rA-O4*-set! rA-C1*-set! rA-H1*-set! + rA-C2*-set! rA-H2**-set! + rA-O2*-set! rA-H2*-set! rA-C3*-set! rA-H3*-set! rA-O3*-set! + rA-N1-set! rA-N3-set! rA-C2-set! rA-C4-set! rA-C5-set! rA-C6-set! + rA-N6-set! rA-N7-set! rA-N9-set! rA-C8-set! + rA-H2-set! rA-H61-set! rA-H62-set! rA-H8-set!)) + +(define-structure rC? rC + make-rC make-constant-rC + (rC-dgf-base-tfo ; defines the standard position for wc and wc-dumas + rC-P-O3*-275-tfo ; defines the standard position for the connect function + rC-P-O3*-180-tfo + rC-P-O3*-60-tfo + rC-P rC-O1P rC-O2P rC-O5* rC-C5* + rC-H5* rC-H5** + rC-C4* rC-H4* rC-O4* rC-C1* rC-H1* + rC-C2* rC-H2** + rC-O2* rC-H2* rC-C3* rC-H3* rC-O3* + rC-N1 rC-N3 rC-C2 rC-C4 rC-C5 rC-C6 + rC-N4 rC-O2 rC-H41 rC-H42 rC-H5 rC-H6) + (rC-dgf-base-tfo-set! + rC-P-O3*-275-tfo-set! + rC-P-O3*-180-tfo-set! + rC-P-O3*-60-tfo-set! + rC-P-set! rC-O1P-set! rC-O2P-set! rC-O5*-set! rC-C5*-set! + rC-H5*-set! rC-H5**-set! + rC-C4*-set! rC-H4*-set! rC-O4*-set! rC-C1*-set! rC-H1*-set! + rC-C2*-set! rC-H2**-set! + rC-O2*-set! rC-H2*-set! rC-C3*-set! rC-H3*-set! rC-O3*-set! + rC-N1-set! rC-N3-set! rC-C2-set! rC-C4-set! rC-C5-set! rC-C6-set! + rC-N4-set! rC-O2-set! rC-H41-set! rC-H42-set! rC-H5-set! rC-H6-set!)) + +(define-structure rG? rG + make-rG make-constant-rG + (rG-dgf-base-tfo ; defines the standard position for wc and wc-dumas + rG-P-O3*-275-tfo ; defines the standard position for the connect function + rG-P-O3*-180-tfo + rG-P-O3*-60-tfo + rG-P rG-O1P rG-O2P rG-O5* rG-C5* + rG-H5* rG-H5** + rG-C4* rG-H4* rG-O4* rG-C1* rG-H1* + rG-C2* rG-H2** + rG-O2* rG-H2* rG-C3* rG-H3* rG-O3* + rG-N1 rG-N3 rG-C2 rG-C4 rG-C5 rG-C6 + rG-N2 rG-N7 rG-N9 rG-C8 rG-O6 + rG-H1 rG-H21 rG-H22 rG-H8) + (rG-dgf-base-tfo-set! + rG-P-O3*-275-tfo-set! + rG-P-O3*-180-tfo-set! + rG-P-O3*-60-tfo-set! + rG-P-set! rG-O1P-set! rG-O2P-set! rG-O5*-set! rG-C5*-set! + rG-H5*-set! rG-H5**-set! + rG-C4*-set! rG-H4*-set! rG-O4*-set! rG-C1*-set! rG-H1*-set! + rG-C2*-set! rG-H2**-set! + rG-O2*-set! rG-H2*-set! rG-C3*-set! rG-H3*-set! rG-O3*-set! + rG-N1-set! rG-N3-set! rG-C2-set! rG-C4-set! rG-C5-set! rG-C6-set! + rG-N2-set! rG-N7-set! rG-N9-set! rG-C8-set! rG-O6-set! + rG-H1-set! rG-H21-set! rG-H22-set! rG-H8-set!)) + +(define-structure rU? rU + make-rU make-constant-rU + (rU-dgf-base-tfo ; defines the standard position for wc and wc-dumas + rU-P-O3*-275-tfo ; defines the standard position for the connect function + rU-P-O3*-180-tfo + rU-P-O3*-60-tfo + rU-P rU-O1P rU-O2P rU-O5* rU-C5* + rU-H5* rU-H5** + rU-C4* rU-H4* rU-O4* rU-C1* rU-H1* + rU-C2* rU-H2** + rU-O2* rU-H2* rU-C3* rU-H3* rU-O3* + rU-N1 rU-N3 rU-C2 rU-C4 rU-C5 rU-C6 + rU-O2 rU-O4 rU-H3 rU-H5 rU-H6) + (rU-dgf-base-tfo-set! + rU-P-O3*-275-tfo-set! + rU-P-O3*-180-tfo-set! + rU-P-O3*-60-tfo-set! + rU-P-set! rU-O1P-set! rU-O2P-set! rU-O5*-set! rU-C5*-set! + rU-H5*-set! rU-H5**-set! + rU-C4*-set! rU-H4*-set! rU-O4*-set! rU-C1*-set! rU-H1*-set! + rU-C2*-set! rU-H2**-set! + rU-O2*-set! rU-H2*-set! rU-C3*-set! rU-H3*-set! rU-O3*-set! + rU-N1-set! rU-N3-set! rU-C2-set! rU-C4-set! rU-C5-set! rU-C6-set! + rU-O2-set! rU-O4-set! rU-H3-set! rU-H5-set! rU-H6-set!)) + +(define-structure #f var + make-var make-constant-var + (var-id var-tfo var-nuc) + (var-id-set! var-tfo-set! var-nuc-set!)) + +; Comment out the next three syntax definitions if you want +; lazy computation. + +(define-syntax mk-var + (syntax-rules () + ((mk-var i tfo nuc) + (make-var i tfo nuc)))) + +(define-syntax absolute-pos + (syntax-rules () + ((absolute-pos var p) + (tfo-apply (var-tfo var) p)))) + +(define-syntax lazy-computation-of + (syntax-rules () + ((lazy-computation-of expr) + expr))) + +; Uncomment the next three syntax definitions if you want +; lazy computation. + +; (define-syntax mk-var +; (syntax-rules () +; ((mk-var i tfo nuc) +; (make-var i tfo (make-relative-nuc tfo nuc))))) +; +; (define-syntax absolute-pos +; (syntax-rules () +; ((absolute-pos var p) +; (force p)))) +; +; (define-syntax lazy-computation-of +; (syntax-rules () +; ((lazy-computation-of expr) +; (delay expr)))) + +(define-syntax atom-pos + (syntax-rules () + ((atom-pos atom var) + (let ((v var)) + (absolute-pos v (atom (var-nuc v))))))) + +) + +; -- MATH UTILITIES ----------------------------------------------------------- + +(define constant-pi 3.14159265358979323846) +(define constant-minus-pi -3.14159265358979323846) +(define constant-pi/2 1.57079632679489661923) +(define constant-minus-pi/2 -1.57079632679489661923) + +(define (math-atan2 y x) + (cond ((FLOAT> x 0.0) + (FLOATatan (FLOAT/ y x))) + ((FLOAT< y 0.0) + (if (FLOAT= x 0.0) + constant-minus-pi/2 + (FLOAT+ (FLOATatan (FLOAT/ y x)) constant-minus-pi))) + (else + (if (FLOAT= x 0.0) + constant-pi/2 + (FLOAT+ (FLOATatan (FLOAT/ y x)) constant-pi))))) + +; -- POINTS ------------------------------------------------------------------- + +(define (pt-sub p1 p2) + (make-pt (FLOAT- (pt-x p1) (pt-x p2)) + (FLOAT- (pt-y p1) (pt-y p2)) + (FLOAT- (pt-z p1) (pt-z p2)))) + +(define (pt-dist p1 p2) + (let ((dx (FLOAT- (pt-x p1) (pt-x p2))) + (dy (FLOAT- (pt-y p1) (pt-y p2))) + (dz (FLOAT- (pt-z p1) (pt-z p2)))) + (FLOATsqrt (FLOAT+ (FLOAT* dx dx) (FLOAT* dy dy) (FLOAT* dz dz))))) + +(define (pt-phi p) + (let* ((x (pt-x p)) + (y (pt-y p)) + (z (pt-z p)) + (b (math-atan2 x z))) + (math-atan2 (FLOAT+ (FLOAT* (FLOATcos b) z) (FLOAT* (FLOATsin b) x)) y))) + +(define (pt-theta p) + (math-atan2 (pt-x p) (pt-z p))) + +; -- COORDINATE TRANSFORMATIONS ----------------------------------------------- + +; The notation for the transformations follows "Paul, R.P. (1981) Robot +; Manipulators. MIT Press." with the exception that our transformation +; matrices don't have the perspective terms and are the transpose of +; Paul's one. See also "M\"antyl\"a, M. (1985) An Introduction to +; Solid Modeling, Computer Science Press" Appendix A. +; +; The components of a transformation matrix are named like this: +; +; a b c +; d e f +; g h i +; tx ty tz +; +; The components tx, ty, and tz are the translation vector. + +(define tfo-id ; the identity transformation matrix + '#(1.0 0.0 0.0 + 0.0 1.0 0.0 + 0.0 0.0 1.0 + 0.0 0.0 0.0)) + +; The function "tfo-apply" multiplies a transformation matrix, tfo, by a +; point vector, p. The result is a new point. + +(define (tfo-apply tfo p) + (let ((x (pt-x p)) + (y (pt-y p)) + (z (pt-z p))) + (make-pt + (FLOAT+ (FLOAT* x (tfo-a tfo)) + (FLOAT* y (tfo-d tfo)) + (FLOAT* z (tfo-g tfo)) + (tfo-tx tfo)) + (FLOAT+ (FLOAT* x (tfo-b tfo)) + (FLOAT* y (tfo-e tfo)) + (FLOAT* z (tfo-h tfo)) + (tfo-ty tfo)) + (FLOAT+ (FLOAT* x (tfo-c tfo)) + (FLOAT* y (tfo-f tfo)) + (FLOAT* z (tfo-i tfo)) + (tfo-tz tfo))))) + +; The function "tfo-combine" multiplies two transformation matrices A and B. +; The result is a new matrix which cumulates the transformations described +; by A and B. + +(define (tfo-combine A B) + (make-tfo + (FLOAT+ (FLOAT* (tfo-a A) (tfo-a B)) + (FLOAT* (tfo-b A) (tfo-d B)) + (FLOAT* (tfo-c A) (tfo-g B))) + (FLOAT+ (FLOAT* (tfo-a A) (tfo-b B)) + (FLOAT* (tfo-b A) (tfo-e B)) + (FLOAT* (tfo-c A) (tfo-h B))) + (FLOAT+ (FLOAT* (tfo-a A) (tfo-c B)) + (FLOAT* (tfo-b A) (tfo-f B)) + (FLOAT* (tfo-c A) (tfo-i B))) + (FLOAT+ (FLOAT* (tfo-d A) (tfo-a B)) + (FLOAT* (tfo-e A) (tfo-d B)) + (FLOAT* (tfo-f A) (tfo-g B))) + (FLOAT+ (FLOAT* (tfo-d A) (tfo-b B)) + (FLOAT* (tfo-e A) (tfo-e B)) + (FLOAT* (tfo-f A) (tfo-h B))) + (FLOAT+ (FLOAT* (tfo-d A) (tfo-c B)) + (FLOAT* (tfo-e A) (tfo-f B)) + (FLOAT* (tfo-f A) (tfo-i B))) + (FLOAT+ (FLOAT* (tfo-g A) (tfo-a B)) + (FLOAT* (tfo-h A) (tfo-d B)) + (FLOAT* (tfo-i A) (tfo-g B))) + (FLOAT+ (FLOAT* (tfo-g A) (tfo-b B)) + (FLOAT* (tfo-h A) (tfo-e B)) + (FLOAT* (tfo-i A) (tfo-h B))) + (FLOAT+ (FLOAT* (tfo-g A) (tfo-c B)) + (FLOAT* (tfo-h A) (tfo-f B)) + (FLOAT* (tfo-i A) (tfo-i B))) + (FLOAT+ (FLOAT* (tfo-tx A) (tfo-a B)) + (FLOAT* (tfo-ty A) (tfo-d B)) + (FLOAT* (tfo-tz A) (tfo-g B)) + (tfo-tx B)) + (FLOAT+ (FLOAT* (tfo-tx A) (tfo-b B)) + (FLOAT* (tfo-ty A) (tfo-e B)) + (FLOAT* (tfo-tz A) (tfo-h B)) + (tfo-ty B)) + (FLOAT+ (FLOAT* (tfo-tx A) (tfo-c B)) + (FLOAT* (tfo-ty A) (tfo-f B)) + (FLOAT* (tfo-tz A) (tfo-i B)) + (tfo-tz B)))) + +; The function "tfo-inv-ortho" computes the inverse of a homogeneous +; transformation matrix. + +(define (tfo-inv-ortho tfo) + (let* ((tx (tfo-tx tfo)) + (ty (tfo-ty tfo)) + (tz (tfo-tz tfo))) + (make-tfo + (tfo-a tfo) (tfo-d tfo) (tfo-g tfo) + (tfo-b tfo) (tfo-e tfo) (tfo-h tfo) + (tfo-c tfo) (tfo-f tfo) (tfo-i tfo) + (FLOAT- (FLOAT+ (FLOAT* (tfo-a tfo) tx) + (FLOAT* (tfo-b tfo) ty) + (FLOAT* (tfo-c tfo) tz))) + (FLOAT- (FLOAT+ (FLOAT* (tfo-d tfo) tx) + (FLOAT* (tfo-e tfo) ty) + (FLOAT* (tfo-f tfo) tz))) + (FLOAT- (FLOAT+ (FLOAT* (tfo-g tfo) tx) + (FLOAT* (tfo-h tfo) ty) + (FLOAT* (tfo-i tfo) tz)))))) + +; Given three points p1, p2, and p3, the function "tfo-align" computes +; a transformation matrix such that point p1 gets mapped to (0,0,0), p2 gets +; mapped to the Y axis and p3 gets mapped to the YZ plane. + +(define (tfo-align p1 p2 p3) + (let* ((x1 (pt-x p1)) (y1 (pt-y p1)) (z1 (pt-z p1)) + (x3 (pt-x p3)) (y3 (pt-y p3)) (z3 (pt-z p3)) + (x31 (FLOAT- x3 x1)) (y31 (FLOAT- y3 y1)) (z31 (FLOAT- z3 z1)) + (rotpY (pt-sub p2 p1)) + (Phi (pt-phi rotpY)) + (Theta (pt-theta rotpY)) + (sinP (FLOATsin Phi)) + (sinT (FLOATsin Theta)) + (cosP (FLOATcos Phi)) + (cosT (FLOATcos Theta)) + (sinPsinT (FLOAT* sinP sinT)) + (sinPcosT (FLOAT* sinP cosT)) + (cosPsinT (FLOAT* cosP sinT)) + (cosPcosT (FLOAT* cosP cosT)) + (rotpZ + (make-pt + (FLOAT- (FLOAT* cosT x31) + (FLOAT* sinT z31)) + (FLOAT+ (FLOAT* sinPsinT x31) + (FLOAT* cosP y31) + (FLOAT* sinPcosT z31)) + (FLOAT+ (FLOAT* cosPsinT x31) + (FLOAT- (FLOAT* sinP y31)) + (FLOAT* cosPcosT z31)))) + (Rho (pt-theta rotpZ)) + (cosR (FLOATcos Rho)) + (sinR (FLOATsin Rho)) + (x (FLOAT+ (FLOAT- (FLOAT* x1 cosT)) + (FLOAT* z1 sinT))) + (y (FLOAT- (FLOAT- (FLOAT- (FLOAT* x1 sinPsinT)) + (FLOAT* y1 cosP)) + (FLOAT* z1 sinPcosT))) + (z (FLOAT- (FLOAT+ (FLOAT- (FLOAT* x1 cosPsinT)) + (FLOAT* y1 sinP)) + (FLOAT* z1 cosPcosT)))) + (make-tfo + (FLOAT- (FLOAT* cosT cosR) (FLOAT* cosPsinT sinR)) + sinPsinT + (FLOAT+ (FLOAT* cosT sinR) (FLOAT* cosPsinT cosR)) + (FLOAT* sinP sinR) + cosP + (FLOAT- (FLOAT* sinP cosR)) + (FLOAT- (FLOAT- (FLOAT* sinT cosR)) (FLOAT* cosPcosT sinR)) + sinPcosT + (FLOAT+ (FLOAT- (FLOAT* sinT sinR)) (FLOAT* cosPcosT cosR)) + (FLOAT- (FLOAT* x cosR) (FLOAT* z sinR)) + y + (FLOAT+ (FLOAT* x sinR) (FLOAT* z cosR))))) + +; -- NUCLEIC ACID CONFORMATIONS DATA BASE ------------------------------------- + +; Numbering of atoms follows the paper: +; +; IUPAC-IUB Joint Commission on Biochemical Nomenclature (JCBN) +; (1983) Abbreviations and Symbols for the Description of +; Conformations of Polynucleotide Chains. Eur. J. Biochem 131, +; 9-15. +; +; In the atom names, we have used "*" instead of "'". + +; Define part common to all 4 nucleotide types. + +; Define remaining atoms for each nucleotide type. + +; Database of nucleotide conformations: + +(define rA + (make-constant-rA + #( -0.0018 -0.8207 0.5714 ; dgf-base-tfo + 0.2679 -0.5509 -0.7904 + 0.9634 0.1517 0.2209 + 0.0073 8.4030 0.6232) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 5.4550 8.2120 -2.8810) ; C5* + #( 5.4546 8.8508 -1.9978) ; H5* + #( 5.7588 8.6625 -3.8259) ; H5** + #( 6.4970 7.1480 -2.5980) ; C4* + #( 7.4896 7.5919 -2.5214) ; H4* + #( 6.1630 6.4860 -1.3440) ; O4* + #( 6.5400 5.1200 -1.4190) ; C1* + #( 7.2763 4.9681 -0.6297) ; H1* + #( 7.1940 4.8830 -2.7770) ; C2* + #( 6.8667 3.9183 -3.1647) ; H2** + #( 8.5860 5.0910 -2.6140) ; O2* + #( 8.9510 4.7626 -1.7890) ; H2* + #( 6.5720 6.0040 -3.6090) ; C3* + #( 5.5636 5.7066 -3.8966) ; H3* + #( 7.3801 6.3562 -4.7350) ; O3* + #( 4.7150 0.4910 -0.1360) ; N1 + #( 6.3490 2.1730 -0.6020) ; N3 + #( 5.9530 0.9650 -0.2670) ; C2 + #( 5.2900 2.9790 -0.8260) ; C4 + #( 3.9720 2.6390 -0.7330) ; C5 + #( 3.6770 1.3160 -0.3660) ; C6 + #( 2.4280 0.8450 -0.2360) ; N6 + #( 3.1660 3.7290 -1.0360) ; N7 + #( 5.3170 4.2990 -1.1930) ; N9 + #( 4.0100 4.6780 -1.2990) ; C8 + #( 6.6890 0.1903 -0.0518) ; H2 + #( 1.6470 1.4460 -0.4040) ; H61 + #( 2.2780 -0.1080 -0.0280) ; H62 + #( 3.4421 5.5744 -1.5482) ; H8 + )) + +(define rA01 + (make-constant-rA + #( -0.0043 -0.8175 0.5759 ; dgf-base-tfo + 0.2617 -0.5567 -0.7884 + 0.9651 0.1473 0.2164 + 0.0359 8.3929 0.5532) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 5.4352 8.2183 -2.7757) ; C5* + #( 5.3830 8.7883 -1.8481) ; H5* + #( 5.7729 8.7436 -3.6691) ; H5** + #( 6.4830 7.1518 -2.5252) ; C4* + #( 7.4749 7.5972 -2.4482) ; H4* + #( 6.1626 6.4620 -1.2827) ; O4* + #( 6.5431 5.0992 -1.3905) ; C1* + #( 7.2871 4.9328 -0.6114) ; H1* + #( 7.1852 4.8935 -2.7592) ; C2* + #( 6.8573 3.9363 -3.1645) ; H2** + #( 8.5780 5.1025 -2.6046) ; O2* + #( 8.9516 4.7577 -1.7902) ; H2* + #( 6.5522 6.0300 -3.5612) ; C3* + #( 5.5420 5.7356 -3.8459) ; H3* + #( 7.3487 6.4089 -4.6867) ; O3* + #( 4.7442 0.4514 -0.1390) ; N1 + #( 6.3687 2.1459 -0.5926) ; N3 + #( 5.9795 0.9335 -0.2657) ; C2 + #( 5.3052 2.9471 -0.8125) ; C4 + #( 3.9891 2.5987 -0.7230) ; C5 + #( 3.7016 1.2717 -0.3647) ; C6 + #( 2.4553 0.7925 -0.2390) ; N6 + #( 3.1770 3.6859 -1.0198) ; N7 + #( 5.3247 4.2695 -1.1710) ; N9 + #( 4.0156 4.6415 -1.2759) ; C8 + #( 6.7198 0.1618 -0.0547) ; H2 + #( 1.6709 1.3900 -0.4039) ; H61 + #( 2.3107 -0.1627 -0.0373) ; H62 + #( 3.4426 5.5361 -1.5199) ; H8 + )) + +(define rA02 + (make-constant-rA + #( 0.5566 0.0449 0.8296 ; dgf-base-tfo + 0.5125 0.7673 -0.3854 + -0.6538 0.6397 0.4041 + -9.1161 -3.7679 -2.9968) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.5778 6.6594 -4.0364) ; C5* + #( 4.9220 7.1963 -4.9204) ; H5* + #( 3.7996 5.9091 -4.1764) ; H5** + #( 5.7873 5.8869 -3.5482) ; C4* + #( 6.0405 5.0875 -4.2446) ; H4* + #( 6.9135 6.8036 -3.4310) ; O4* + #( 7.7293 6.4084 -2.3392) ; C1* + #( 8.7078 6.1815 -2.7624) ; H1* + #( 7.1305 5.1418 -1.7347) ; C2* + #( 7.2040 5.1982 -0.6486) ; H2** + #( 7.7417 4.0392 -2.3813) ; O2* + #( 8.6785 4.1443 -2.5630) ; H2* + #( 5.6666 5.2728 -2.1536) ; C3* + #( 5.1747 5.9805 -1.4863) ; H3* + #( 4.9997 4.0086 -2.1973) ; O3* + #( 10.3245 8.5459 1.5467) ; N1 + #( 9.8051 6.9432 -0.1497) ; N3 + #( 10.5175 7.4328 0.8408) ; C2 + #( 8.7523 7.7422 -0.4228) ; C4 + #( 8.4257 8.9060 0.2099) ; C5 + #( 9.2665 9.3242 1.2540) ; C6 + #( 9.0664 10.4462 1.9610) ; N6 + #( 7.2750 9.4537 -0.3428) ; N7 + #( 7.7962 7.5519 -1.3859) ; N9 + #( 6.9479 8.6157 -1.2771) ; C8 + #( 11.4063 6.9047 1.1859) ; H2 + #( 8.2845 11.0341 1.7552) ; H61 + #( 9.6584 10.6647 2.7198) ; H62 + #( 6.0430 8.9853 -1.7594) ; H8 + )) + +(define rA03 + (make-constant-rA + #( -0.5021 0.0731 0.8617 ; dgf-base-tfo + -0.8112 0.3054 -0.4986 + -0.2996 -0.9494 -0.0940 + 6.4273 -5.1944 -3.7807) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.1214 6.7116 -1.9049) ; C5* + #( 3.3465 5.9610 -2.0607) ; H5* + #( 4.0789 7.2928 -0.9837) ; H5** + #( 5.4170 5.9293 -1.8186) ; C4* + #( 5.4506 5.3400 -0.9023) ; H4* + #( 5.5067 5.0417 -2.9703) ; O4* + #( 6.8650 4.9152 -3.3612) ; C1* + #( 7.1090 3.8577 -3.2603) ; H1* + #( 7.7152 5.7282 -2.3894) ; C2* + #( 8.5029 6.2356 -2.9463) ; H2** + #( 8.1036 4.8568 -1.3419) ; O2* + #( 8.3270 3.9651 -1.6184) ; H2* + #( 6.7003 6.7565 -1.8911) ; C3* + #( 6.5898 7.5329 -2.6482) ; H3* + #( 7.0505 7.2878 -0.6105) ; O3* + #( 9.6740 4.7656 -7.6614) ; N1 + #( 9.0739 4.3013 -5.3941) ; N3 + #( 9.8416 4.2192 -6.4581) ; C2 + #( 7.9885 5.0632 -5.6446) ; C4 + #( 7.6822 5.6856 -6.8194) ; C5 + #( 8.5831 5.5215 -7.8840) ; C6 + #( 8.4084 6.0747 -9.0933) ; N6 + #( 6.4857 6.3816 -6.7035) ; N7 + #( 6.9740 5.3703 -4.7760) ; N9 + #( 6.1133 6.1613 -5.4808) ; C8 + #( 10.7627 3.6375 -6.4220) ; H2 + #( 7.6031 6.6390 -9.2733) ; H61 + #( 9.1004 5.9708 -9.7893) ; H62 + #( 5.1705 6.6830 -5.3167) ; H8 + )) + +(define rA04 + (make-constant-rA + #( -0.5426 -0.8175 0.1929 ; dgf-base-tfo + 0.8304 -0.5567 -0.0237 + 0.1267 0.1473 0.9809 + -0.5075 8.3929 0.2229) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 5.4352 8.2183 -2.7757) ; C5* + #( 5.3830 8.7883 -1.8481) ; H5* + #( 5.7729 8.7436 -3.6691) ; H5** + #( 6.4830 7.1518 -2.5252) ; C4* + #( 7.4749 7.5972 -2.4482) ; H4* + #( 6.1626 6.4620 -1.2827) ; O4* + #( 6.5431 5.0992 -1.3905) ; C1* + #( 7.2871 4.9328 -0.6114) ; H1* + #( 7.1852 4.8935 -2.7592) ; C2* + #( 6.8573 3.9363 -3.1645) ; H2** + #( 8.5780 5.1025 -2.6046) ; O2* + #( 8.9516 4.7577 -1.7902) ; H2* + #( 6.5522 6.0300 -3.5612) ; C3* + #( 5.5420 5.7356 -3.8459) ; H3* + #( 7.3487 6.4089 -4.6867) ; O3* + #( 3.6343 2.6680 2.0783) ; N1 + #( 5.4505 3.9805 1.2446) ; N3 + #( 4.7540 3.3816 2.1851) ; C2 + #( 4.8805 3.7951 0.0354) ; C4 + #( 3.7416 3.0925 -0.2305) ; C5 + #( 3.0873 2.4980 0.8606) ; C6 + #( 1.9600 1.7805 0.7462) ; N6 + #( 3.4605 3.1184 -1.5906) ; N7 + #( 5.3247 4.2695 -1.1710) ; N9 + #( 4.4244 3.8244 -2.0953) ; C8 + #( 5.0814 3.4352 3.2234) ; H2 + #( 1.5423 1.6454 -0.1520) ; H61 + #( 1.5716 1.3398 1.5392) ; H62 + #( 4.2675 3.8876 -3.1721) ; H8 + )) + +(define rA05 + (make-constant-rA + #( -0.5891 0.0449 0.8068 ; dgf-base-tfo + 0.5375 0.7673 0.3498 + -0.6034 0.6397 -0.4762 + -0.3019 -3.7679 -9.5913) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.5778 6.6594 -4.0364) ; C5* + #( 4.9220 7.1963 -4.9204) ; H5* + #( 3.7996 5.9091 -4.1764) ; H5** + #( 5.7873 5.8869 -3.5482) ; C4* + #( 6.0405 5.0875 -4.2446) ; H4* + #( 6.9135 6.8036 -3.4310) ; O4* + #( 7.7293 6.4084 -2.3392) ; C1* + #( 8.7078 6.1815 -2.7624) ; H1* + #( 7.1305 5.1418 -1.7347) ; C2* + #( 7.2040 5.1982 -0.6486) ; H2** + #( 7.7417 4.0392 -2.3813) ; O2* + #( 8.6785 4.1443 -2.5630) ; H2* + #( 5.6666 5.2728 -2.1536) ; C3* + #( 5.1747 5.9805 -1.4863) ; H3* + #( 4.9997 4.0086 -2.1973) ; O3* + #( 10.2594 10.6774 -1.0056) ; N1 + #( 9.7528 8.7080 -2.2631) ; N3 + #( 10.4471 9.7876 -1.9791) ; C2 + #( 8.7271 8.5575 -1.3991) ; C4 + #( 8.4100 9.3803 -0.3580) ; C5 + #( 9.2294 10.5030 -0.1574) ; C6 + #( 9.0349 11.3951 0.8250) ; N6 + #( 7.2891 8.9068 0.3121) ; N7 + #( 7.7962 7.5519 -1.3859) ; N9 + #( 6.9702 7.8292 -0.3353) ; C8 + #( 11.3132 10.0537 -2.5851) ; H2 + #( 8.2741 11.2784 1.4629) ; H61 + #( 9.6733 12.1368 0.9529) ; H62 + #( 6.0888 7.3990 0.1403) ; H8 + )) + +(define rA06 + (make-constant-rA + #( -0.9815 0.0731 -0.1772 ; dgf-base-tfo + 0.1912 0.3054 -0.9328 + -0.0141 -0.9494 -0.3137 + 5.7506 -5.1944 4.7470) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.1214 6.7116 -1.9049) ; C5* + #( 3.3465 5.9610 -2.0607) ; H5* + #( 4.0789 7.2928 -0.9837) ; H5** + #( 5.4170 5.9293 -1.8186) ; C4* + #( 5.4506 5.3400 -0.9023) ; H4* + #( 5.5067 5.0417 -2.9703) ; O4* + #( 6.8650 4.9152 -3.3612) ; C1* + #( 7.1090 3.8577 -3.2603) ; H1* + #( 7.7152 5.7282 -2.3894) ; C2* + #( 8.5029 6.2356 -2.9463) ; H2** + #( 8.1036 4.8568 -1.3419) ; O2* + #( 8.3270 3.9651 -1.6184) ; H2* + #( 6.7003 6.7565 -1.8911) ; C3* + #( 6.5898 7.5329 -2.6482) ; H3* + #( 7.0505 7.2878 -0.6105) ; O3* + #( 6.6624 3.5061 -8.2986) ; N1 + #( 6.5810 3.2570 -5.9221) ; N3 + #( 6.5151 2.8263 -7.1625) ; C2 + #( 6.8364 4.5817 -5.8882) ; C4 + #( 7.0116 5.4064 -6.9609) ; C5 + #( 6.9173 4.8260 -8.2361) ; C6 + #( 7.0668 5.5163 -9.3763) ; N6 + #( 7.2573 6.7070 -6.5394) ; N7 + #( 6.9740 5.3703 -4.7760) ; N9 + #( 7.2238 6.6275 -5.2453) ; C8 + #( 6.3146 1.7741 -7.3641) ; H2 + #( 7.2568 6.4972 -9.3456) ; H61 + #( 7.0437 5.0478 -10.2446) ; H62 + #( 7.4108 7.6227 -4.8418) ; H8 + )) + +(define rA07 + (make-constant-rA + #( 0.2379 0.1310 -0.9624 ; dgf-base-tfo + -0.5876 -0.7696 -0.2499 + -0.7734 0.6249 -0.1061 + 30.9870 -26.9344 42.6416) + #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo + 0.2952 -0.9481 -0.1180 + 0.5882 0.2777 -0.7595 + -58.8919 -11.3095 6.0866) + #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo + 0.9731 -0.0359 -0.2275 + -0.2290 -0.2532 -0.9399 + 3.5401 -29.7913 52.2796) + #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo + -0.1183 0.1805 -0.9764 + 0.4380 -0.8730 -0.2145 + 19.9023 54.8054 15.2799) + #( 41.8210 8.3880 43.5890) ; P + #( 42.5400 8.0450 44.8330) ; O1P + #( 42.2470 9.6920 42.9910) ; O2P + #( 40.2550 8.2030 43.7340) ; O5* + #( 39.3505 8.4697 42.6565) ; C5* + #( 39.1377 7.5433 42.1230) ; H5* + #( 39.7203 9.3119 42.0717) ; H5** + #( 38.0405 8.9195 43.2869) ; C4* + #( 37.3687 9.3036 42.5193) ; H4* + #( 37.4319 7.8146 43.9387) ; O4* + #( 37.1959 8.1354 45.3237) ; C1* + #( 36.1788 8.5202 45.3970) ; H1* + #( 38.1721 9.2328 45.6504) ; C2* + #( 39.1555 8.7939 45.8188) ; H2** + #( 37.7862 10.0617 46.7013) ; O2* + #( 37.3087 9.6229 47.4092) ; H2* + #( 38.1844 10.0268 44.3367) ; C3* + #( 39.1578 10.5054 44.2289) ; H3* + #( 37.0547 10.9127 44.3441) ; O3* + #( 34.8811 4.2072 47.5784) ; N1 + #( 35.1084 6.1336 46.1818) ; N3 + #( 34.4108 5.1360 46.7207) ; C2 + #( 36.3908 6.1224 46.6053) ; C4 + #( 36.9819 5.2334 47.4697) ; C5 + #( 36.1786 4.1985 48.0035) ; C6 + #( 36.6103 3.2749 48.8452) ; N6 + #( 38.3236 5.5522 47.6595) ; N7 + #( 37.3887 7.0024 46.2437) ; N9 + #( 38.5055 6.6096 46.9057) ; C8 + #( 33.3553 5.0152 46.4771) ; H2 + #( 37.5730 3.2804 49.1507) ; H61 + #( 35.9775 2.5638 49.1828) ; H62 + #( 39.5461 6.9184 47.0041) ; H8 + )) + +(define rA08 + (make-constant-rA + #( 0.1084 -0.0895 -0.9901 ; dgf-base-tfo + 0.9789 -0.1638 0.1220 + -0.1731 -0.9824 0.0698 + -2.9039 47.2655 33.0094) + #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo + 0.2952 -0.9481 -0.1180 + 0.5882 0.2777 -0.7595 + -58.8919 -11.3095 6.0866) + #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo + 0.9731 -0.0359 -0.2275 + -0.2290 -0.2532 -0.9399 + 3.5401 -29.7913 52.2796) + #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo + -0.1183 0.1805 -0.9764 + 0.4380 -0.8730 -0.2145 + 19.9023 54.8054 15.2799) + #( 41.8210 8.3880 43.5890) ; P + #( 42.5400 8.0450 44.8330) ; O1P + #( 42.2470 9.6920 42.9910) ; O2P + #( 40.2550 8.2030 43.7340) ; O5* + #( 39.4850 8.9301 44.6977) ; C5* + #( 39.0638 9.8199 44.2296) ; H5* + #( 40.0757 9.0713 45.6029) ; H5** + #( 38.3102 8.0414 45.0789) ; C4* + #( 37.7842 8.4637 45.9351) ; H4* + #( 37.4200 7.9453 43.9769) ; O4* + #( 37.2249 6.5609 43.6273) ; C1* + #( 36.3360 6.2168 44.1561) ; H1* + #( 38.4347 5.8414 44.1590) ; C2* + #( 39.2688 5.9974 43.4749) ; H2** + #( 38.2344 4.4907 44.4348) ; O2* + #( 37.6374 4.0386 43.8341) ; H2* + #( 38.6926 6.6079 45.4637) ; C3* + #( 39.7585 6.5640 45.6877) ; H3* + #( 37.8238 6.0705 46.4723) ; O3* + #( 33.9162 6.2598 39.7758) ; N1 + #( 34.6709 6.5759 42.0215) ; N3 + #( 33.7257 6.5186 41.0858) ; C2 + #( 35.8935 6.3324 41.5018) ; C4 + #( 36.2105 6.0601 40.1932) ; C5 + #( 35.1538 6.0151 39.2537) ; C6 + #( 35.3088 5.7642 37.9649) ; N6 + #( 37.5818 5.8677 40.0507) ; N7 + #( 37.0932 6.3197 42.1810) ; N9 + #( 38.0509 6.0354 41.2635) ; C8 + #( 32.6830 6.6898 41.3532) ; H2 + #( 36.2305 5.5855 37.5925) ; H61 + #( 34.5056 5.7512 37.3528) ; H62 + #( 39.1318 5.8993 41.2285) ; H8 + )) + +(define rA09 + (make-constant-rA + #( 0.8467 0.4166 -0.3311 ; dgf-base-tfo + -0.3962 0.9089 0.1303 + 0.3552 0.0209 0.9346 + -42.7319 -26.6223 -29.8163) + #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo + 0.2952 -0.9481 -0.1180 + 0.5882 0.2777 -0.7595 + -58.8919 -11.3095 6.0866) + #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo + 0.9731 -0.0359 -0.2275 + -0.2290 -0.2532 -0.9399 + 3.5401 -29.7913 52.2796) + #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo + -0.1183 0.1805 -0.9764 + 0.4380 -0.8730 -0.2145 + 19.9023 54.8054 15.2799) + #( 41.8210 8.3880 43.5890) ; P + #( 42.5400 8.0450 44.8330) ; O1P + #( 42.2470 9.6920 42.9910) ; O2P + #( 40.2550 8.2030 43.7340) ; O5* + #( 39.3505 8.4697 42.6565) ; C5* + #( 39.1377 7.5433 42.1230) ; H5* + #( 39.7203 9.3119 42.0717) ; H5** + #( 38.0405 8.9195 43.2869) ; C4* + #( 37.6479 8.1347 43.9335) ; H4* + #( 38.2691 10.0933 44.0524) ; O4* + #( 37.3999 11.1488 43.5973) ; C1* + #( 36.5061 11.1221 44.2206) ; H1* + #( 37.0364 10.7838 42.1836) ; C2* + #( 37.8636 11.0489 41.5252) ; H2** + #( 35.8275 11.3133 41.7379) ; O2* + #( 35.6214 12.1896 42.0714) ; H2* + #( 36.9316 9.2556 42.2837) ; C3* + #( 37.1778 8.8260 41.3127) ; H3* + #( 35.6285 8.9334 42.7926) ; O3* + #( 38.1482 15.2833 46.4641) ; N1 + #( 37.3641 13.0968 45.9007) ; N3 + #( 37.5032 14.1288 46.7300) ; C2 + #( 37.9570 13.3377 44.7113) ; C4 + #( 38.6397 14.4660 44.3267) ; C5 + #( 38.7473 15.5229 45.2609) ; C6 + #( 39.3720 16.6649 45.0297) ; N6 + #( 39.1079 14.3351 43.0223) ; N7 + #( 38.0132 12.4868 43.6280) ; N9 + #( 38.7058 13.1402 42.6620) ; C8 + #( 37.0731 14.0857 47.7306) ; H2 + #( 39.8113 16.8281 44.1350) ; H61 + #( 39.4100 17.3741 45.7478) ; H62 + #( 39.0412 12.9660 41.6397) ; H8 + )) + +(define rA10 + (make-constant-rA + #( 0.7063 0.6317 -0.3196 ; dgf-base-tfo + -0.0403 -0.4149 -0.9090 + -0.7068 0.6549 -0.2676 + 6.4402 -52.1496 30.8246) + #( 0.7529 0.1548 0.6397 ; P-O3*-275-tfo + 0.2952 -0.9481 -0.1180 + 0.5882 0.2777 -0.7595 + -58.8919 -11.3095 6.0866) + #( -0.0239 0.9667 -0.2546 ; P-O3*-180-tfo + 0.9731 -0.0359 -0.2275 + -0.2290 -0.2532 -0.9399 + 3.5401 -29.7913 52.2796) + #( -0.8912 -0.4531 0.0242 ; P-O3*-60-tfo + -0.1183 0.1805 -0.9764 + 0.4380 -0.8730 -0.2145 + 19.9023 54.8054 15.2799) + #( 41.8210 8.3880 43.5890) ; P + #( 42.5400 8.0450 44.8330) ; O1P + #( 42.2470 9.6920 42.9910) ; O2P + #( 40.2550 8.2030 43.7340) ; O5* + #( 39.4850 8.9301 44.6977) ; C5* + #( 39.0638 9.8199 44.2296) ; H5* + #( 40.0757 9.0713 45.6029) ; H5** + #( 38.3102 8.0414 45.0789) ; C4* + #( 37.7099 7.8166 44.1973) ; H4* + #( 38.8012 6.8321 45.6380) ; O4* + #( 38.2431 6.6413 46.9529) ; C1* + #( 37.3505 6.0262 46.8385) ; H1* + #( 37.8484 8.0156 47.4214) ; C2* + #( 38.7381 8.5406 47.7690) ; H2** + #( 36.8286 8.0368 48.3701) ; O2* + #( 36.8392 7.3063 48.9929) ; H2* + #( 37.3576 8.6512 46.1132) ; C3* + #( 37.5207 9.7275 46.1671) ; H3* + #( 35.9985 8.2392 45.9032) ; O3* + #( 39.9117 2.2278 48.8527) ; N1 + #( 38.6207 3.6941 47.4757) ; N3 + #( 38.9872 2.4888 47.9057) ; C2 + #( 39.2961 4.6720 48.1174) ; C4 + #( 40.2546 4.5307 49.0912) ; C5 + #( 40.5932 3.2189 49.4985) ; C6 + #( 41.4938 2.9317 50.4229) ; N6 + #( 40.7195 5.7755 49.5060) ; N7 + #( 39.1730 6.0305 47.9170) ; N9 + #( 40.0413 6.6250 48.7728) ; C8 + #( 38.5257 1.5960 47.4838) ; H2 + #( 41.9907 3.6753 50.8921) ; H61 + #( 41.6848 1.9687 50.6599) ; H62 + #( 40.3571 7.6321 49.0452) ; H8 + )) + +(define rAs + (list rA01 rA02 rA03 rA04 rA05 rA06 rA07 rA08 rA09 rA10)) + +(define rC + (make-constant-rC + #( -0.0359 -0.8071 0.5894 ; dgf-base-tfo + -0.2669 0.5761 0.7726 + -0.9631 -0.1296 -0.2361 + 0.1584 8.3434 0.5434) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 5.2430 -8.2420 2.8260) ; C5* + #( 5.1974 -8.8497 1.9223) ; H5* + #( 5.5548 -8.7348 3.7469) ; H5** + #( 6.3140 -7.2060 2.5510) ; C4* + #( 7.2954 -7.6762 2.4898) ; H4* + #( 6.0140 -6.5420 1.2890) ; O4* + #( 6.4190 -5.1840 1.3620) ; C1* + #( 7.1608 -5.0495 0.5747) ; H1* + #( 7.0760 -4.9560 2.7270) ; C2* + #( 6.7770 -3.9803 3.1099) ; H2** + #( 8.4500 -5.1930 2.5810) ; O2* + #( 8.8309 -4.8755 1.7590) ; H2* + #( 6.4060 -6.0590 3.5580) ; C3* + #( 5.4021 -5.7313 3.8281) ; H3* + #( 7.1570 -6.4240 4.7070) ; O3* + #( 5.2170 -4.3260 1.1690) ; N1 + #( 4.2960 -2.2560 0.6290) ; N3 + #( 5.4330 -3.0200 0.7990) ; C2 + #( 2.9930 -2.6780 0.7940) ; C4 + #( 2.8670 -4.0630 1.1830) ; C5 + #( 3.9570 -4.8300 1.3550) ; C6 + #( 2.0187 -1.8047 0.5874) ; N4 + #( 6.5470 -2.5560 0.6290) ; O2 + #( 1.0684 -2.1236 0.7109) ; H41 + #( 2.2344 -0.8560 0.3162) ; H42 + #( 1.8797 -4.4972 1.3404) ; H5 + #( 3.8479 -5.8742 1.6480) ; H6 + )) + +(define rC01 + (make-constant-rC + #( -0.0137 -0.8012 0.5983 ; dgf-base-tfo + -0.2523 0.5817 0.7733 + -0.9675 -0.1404 -0.2101 + 0.2031 8.3874 0.4228) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 5.2416 -8.2422 2.8181) ; C5* + #( 5.2050 -8.8128 1.8901) ; H5* + #( 5.5368 -8.7738 3.7227) ; H5** + #( 6.3232 -7.2037 2.6002) ; C4* + #( 7.3048 -7.6757 2.5577) ; H4* + #( 6.0635 -6.5092 1.3456) ; O4* + #( 6.4697 -5.1547 1.4629) ; C1* + #( 7.2354 -5.0043 0.7018) ; H1* + #( 7.0856 -4.9610 2.8521) ; C2* + #( 6.7777 -3.9935 3.2487) ; H2** + #( 8.4627 -5.1992 2.7423) ; O2* + #( 8.8693 -4.8638 1.9399) ; H2* + #( 6.3877 -6.0809 3.6362) ; C3* + #( 5.3770 -5.7562 3.8834) ; H3* + #( 7.1024 -6.4754 4.7985) ; O3* + #( 5.2764 -4.2883 1.2538) ; N1 + #( 4.3777 -2.2062 0.7229) ; N3 + #( 5.5069 -2.9779 0.9088) ; C2 + #( 3.0693 -2.6246 0.8500) ; C4 + #( 2.9279 -4.0146 1.2149) ; C5 + #( 4.0101 -4.7892 1.4017) ; C6 + #( 2.1040 -1.7437 0.6331) ; N4 + #( 6.6267 -2.5166 0.7728) ; O2 + #( 1.1496 -2.0600 0.7287) ; H41 + #( 2.3303 -0.7921 0.3815) ; H42 + #( 1.9353 -4.4465 1.3419) ; H5 + #( 3.8895 -5.8371 1.6762) ; H6 + )) + +(define rC02 + (make-constant-rC + #( 0.5141 0.0246 0.8574 ; dgf-base-tfo + -0.5547 -0.7529 0.3542 + 0.6542 -0.6577 -0.3734 + -9.1111 -3.4598 -3.2939) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 4.3825 -6.6585 4.0489) ; C5* + #( 4.6841 -7.2019 4.9443) ; H5* + #( 3.6189 -5.8889 4.1625) ; H5** + #( 5.6255 -5.9175 3.5998) ; C4* + #( 5.8732 -5.1228 4.3034) ; H4* + #( 6.7337 -6.8605 3.5222) ; O4* + #( 7.5932 -6.4923 2.4548) ; C1* + #( 8.5661 -6.2983 2.9064) ; H1* + #( 7.0527 -5.2012 1.8322) ; C2* + #( 7.1627 -5.2525 0.7490) ; H2** + #( 7.6666 -4.1249 2.4880) ; O2* + #( 8.5944 -4.2543 2.6981) ; H2* + #( 5.5661 -5.3029 2.2009) ; C3* + #( 5.0841 -6.0018 1.5172) ; H3* + #( 4.9062 -4.0452 2.2042) ; O3* + #( 7.6298 -7.6136 1.4752) ; N1 + #( 8.6945 -8.7046 -0.2857) ; N3 + #( 8.6943 -7.6514 0.6066) ; C2 + #( 7.7426 -9.6987 -0.3801) ; C4 + #( 6.6642 -9.5742 0.5722) ; C5 + #( 6.6391 -8.5592 1.4526) ; C6 + #( 7.9033 -10.6371 -1.3010) ; N4 + #( 9.5840 -6.8186 0.6136) ; O2 + #( 7.2009 -11.3604 -1.3619) ; H41 + #( 8.7058 -10.6168 -1.9140) ; H42 + #( 5.8585 -10.3083 0.5822) ; H5 + #( 5.8197 -8.4773 2.1667) ; H6 + )) + +(define rC03 + (make-constant-rC + #( -0.4993 0.0476 0.8651 ; dgf-base-tfo + 0.8078 -0.3353 0.4847 + 0.3132 0.9409 0.1290 + 6.2989 -5.2303 -3.8577) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 3.9938 -6.7042 1.9023) ; C5* + #( 3.2332 -5.9343 2.0319) ; H5* + #( 3.9666 -7.2863 0.9812) ; H5** + #( 5.3098 -5.9546 1.8564) ; C4* + #( 5.3863 -5.3702 0.9395) ; H4* + #( 5.3851 -5.0642 3.0076) ; O4* + #( 6.7315 -4.9724 3.4462) ; C1* + #( 7.0033 -3.9202 3.3619) ; H1* + #( 7.5997 -5.8018 2.4948) ; C2* + #( 8.3627 -6.3254 3.0707) ; H2** + #( 8.0410 -4.9501 1.4724) ; O2* + #( 8.2781 -4.0644 1.7570) ; H2* + #( 6.5701 -6.8129 1.9714) ; C3* + #( 6.4186 -7.5809 2.7299) ; H3* + #( 6.9357 -7.3841 0.7235) ; O3* + #( 6.8024 -5.4718 4.8475) ; N1 + #( 7.9218 -5.5700 6.8877) ; N3 + #( 7.8908 -5.0886 5.5944) ; C2 + #( 6.9789 -6.3827 7.4823) ; C4 + #( 5.8742 -6.7319 6.6202) ; C5 + #( 5.8182 -6.2769 5.3570) ; C6 + #( 7.1702 -6.7511 8.7402) ; N4 + #( 8.7747 -4.3728 5.1568) ; O2 + #( 6.4741 -7.3461 9.1662) ; H41 + #( 7.9889 -6.4396 9.2429) ; H42 + #( 5.0736 -7.3713 6.9922) ; H5 + #( 4.9784 -6.5473 4.7170) ; H6 + )) + +(define rC04 + (make-constant-rC + #( -0.5669 -0.8012 0.1918 ; dgf-base-tfo + -0.8129 0.5817 0.0273 + -0.1334 -0.1404 -0.9811 + -0.3279 8.3874 0.3355) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 5.2416 -8.2422 2.8181) ; C5* + #( 5.2050 -8.8128 1.8901) ; H5* + #( 5.5368 -8.7738 3.7227) ; H5** + #( 6.3232 -7.2037 2.6002) ; C4* + #( 7.3048 -7.6757 2.5577) ; H4* + #( 6.0635 -6.5092 1.3456) ; O4* + #( 6.4697 -5.1547 1.4629) ; C1* + #( 7.2354 -5.0043 0.7018) ; H1* + #( 7.0856 -4.9610 2.8521) ; C2* + #( 6.7777 -3.9935 3.2487) ; H2** + #( 8.4627 -5.1992 2.7423) ; O2* + #( 8.8693 -4.8638 1.9399) ; H2* + #( 6.3877 -6.0809 3.6362) ; C3* + #( 5.3770 -5.7562 3.8834) ; H3* + #( 7.1024 -6.4754 4.7985) ; O3* + #( 5.2764 -4.2883 1.2538) ; N1 + #( 3.8961 -3.0896 -0.1893) ; N3 + #( 5.0095 -3.8907 -0.0346) ; C2 + #( 3.0480 -2.6632 0.8116) ; C4 + #( 3.4093 -3.1310 2.1292) ; C5 + #( 4.4878 -3.9124 2.3088) ; C6 + #( 2.0216 -1.8941 0.4804) ; N4 + #( 5.7005 -4.2164 -0.9842) ; O2 + #( 1.4067 -1.5873 1.2205) ; H41 + #( 1.8721 -1.6319 -0.4835) ; H42 + #( 2.8048 -2.8507 2.9918) ; H5 + #( 4.7491 -4.2593 3.3085) ; H6 + )) + +(define rC05 + (make-constant-rC + #( -0.6298 0.0246 0.7763 ; dgf-base-tfo + -0.5226 -0.7529 -0.4001 + 0.5746 -0.6577 0.4870 + -0.0208 -3.4598 -9.6882) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 4.3825 -6.6585 4.0489) ; C5* + #( 4.6841 -7.2019 4.9443) ; H5* + #( 3.6189 -5.8889 4.1625) ; H5** + #( 5.6255 -5.9175 3.5998) ; C4* + #( 5.8732 -5.1228 4.3034) ; H4* + #( 6.7337 -6.8605 3.5222) ; O4* + #( 7.5932 -6.4923 2.4548) ; C1* + #( 8.5661 -6.2983 2.9064) ; H1* + #( 7.0527 -5.2012 1.8322) ; C2* + #( 7.1627 -5.2525 0.7490) ; H2** + #( 7.6666 -4.1249 2.4880) ; O2* + #( 8.5944 -4.2543 2.6981) ; H2* + #( 5.5661 -5.3029 2.2009) ; C3* + #( 5.0841 -6.0018 1.5172) ; H3* + #( 4.9062 -4.0452 2.2042) ; O3* + #( 7.6298 -7.6136 1.4752) ; N1 + #( 8.5977 -9.5977 0.7329) ; N3 + #( 8.5951 -8.5745 1.6594) ; C2 + #( 7.7372 -9.7371 -0.3364) ; C4 + #( 6.7596 -8.6801 -0.4476) ; C5 + #( 6.7338 -7.6721 0.4408) ; C6 + #( 7.8849 -10.7881 -1.1289) ; N4 + #( 9.3993 -8.5377 2.5743) ; O2 + #( 7.2499 -10.8809 -1.9088) ; H41 + #( 8.6122 -11.4649 -0.9468) ; H42 + #( 6.0317 -8.6941 -1.2588) ; H5 + #( 5.9901 -6.8809 0.3459) ; H6 + )) + +(define rC06 + (make-constant-rC + #( -0.9837 0.0476 -0.1733 ; dgf-base-tfo + -0.1792 -0.3353 0.9249 + -0.0141 0.9409 0.3384 + 5.7793 -5.2303 4.5997) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 3.9938 -6.7042 1.9023) ; C5* + #( 3.2332 -5.9343 2.0319) ; H5* + #( 3.9666 -7.2863 0.9812) ; H5** + #( 5.3098 -5.9546 1.8564) ; C4* + #( 5.3863 -5.3702 0.9395) ; H4* + #( 5.3851 -5.0642 3.0076) ; O4* + #( 6.7315 -4.9724 3.4462) ; C1* + #( 7.0033 -3.9202 3.3619) ; H1* + #( 7.5997 -5.8018 2.4948) ; C2* + #( 8.3627 -6.3254 3.0707) ; H2** + #( 8.0410 -4.9501 1.4724) ; O2* + #( 8.2781 -4.0644 1.7570) ; H2* + #( 6.5701 -6.8129 1.9714) ; C3* + #( 6.4186 -7.5809 2.7299) ; H3* + #( 6.9357 -7.3841 0.7235) ; O3* + #( 6.8024 -5.4718 4.8475) ; N1 + #( 6.6920 -5.0495 7.1354) ; N3 + #( 6.6201 -4.5500 5.8506) ; C2 + #( 6.9254 -6.3614 7.4926) ; C4 + #( 7.1046 -7.2543 6.3718) ; C5 + #( 7.0391 -6.7951 5.1106) ; C6 + #( 6.9614 -6.6648 8.7815) ; N4 + #( 6.4083 -3.3696 5.6340) ; O2 + #( 7.1329 -7.6280 9.0324) ; H41 + #( 6.8204 -5.9469 9.4777) ; H42 + #( 7.2954 -8.3135 6.5440) ; H5 + #( 7.1753 -7.4798 4.2735) ; H6 + )) + +(define rC07 + (make-constant-rC + #( 0.0033 0.2720 -0.9623 ; dgf-base-tfo + 0.3013 -0.9179 -0.2584 + -0.9535 -0.2891 -0.0850 + 43.0403 13.7233 34.5710) + #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo + 0.0302 -0.7316 0.6811 + 0.3938 -0.6176 -0.6808 + -48.4330 26.3254 13.6383) + #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo + 0.7581 0.4893 0.4311 + 0.6345 -0.4010 -0.6607 + -31.9784 -13.4285 44.9650) + #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo + -0.6890 0.5694 -0.4484 + 0.3694 -0.2564 -0.8932 + 12.1105 30.8774 46.0946) + #( 33.3400 11.0980 46.1750) ; P + #( 34.5130 10.2320 46.4660) ; O1P + #( 33.4130 12.3960 46.9340) ; O2P + #( 31.9810 10.3390 46.4820) ; O5* + #( 30.8152 11.1619 46.2003) ; C5* + #( 30.4519 10.9454 45.1957) ; H5* + #( 31.0379 12.2016 46.4400) ; H5** + #( 29.7081 10.7448 47.1428) ; C4* + #( 28.8710 11.4416 47.0982) ; H4* + #( 29.2550 9.4394 46.8162) ; O4* + #( 29.3907 8.5625 47.9460) ; C1* + #( 28.4416 8.5669 48.4819) ; H1* + #( 30.4468 9.2031 48.7952) ; C2* + #( 31.4222 8.9651 48.3709) ; H2** + #( 30.3701 8.9157 50.1624) ; O2* + #( 30.0652 8.0304 50.3740) ; H2* + #( 30.1622 10.6879 48.6120) ; C3* + #( 31.0952 11.2399 48.7254) ; H3* + #( 29.1076 11.1535 49.4702) ; O3* + #( 29.7883 7.2209 47.5235) ; N1 + #( 29.1825 5.0438 46.8275) ; N3 + #( 28.8008 6.2912 47.2263) ; C2 + #( 30.4888 4.6890 46.7186) ; C4 + #( 31.5034 5.6405 47.0249) ; C5 + #( 31.1091 6.8691 47.4156) ; C6 + #( 30.8109 3.4584 46.3336) ; N4 + #( 27.6171 6.5989 47.3189) ; O2 + #( 31.7923 3.2301 46.2638) ; H41 + #( 30.0880 2.7857 46.1215) ; H42 + #( 32.5542 5.3634 46.9395) ; H5 + #( 31.8523 7.6279 47.6603) ; H6 + )) + +(define rC08 + (make-constant-rC + #( 0.0797 -0.6026 -0.7941 ; dgf-base-tfo + 0.7939 0.5201 -0.3150 + 0.6028 -0.6054 0.5198 + -36.8341 41.5293 1.6628) + #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo + 0.0302 -0.7316 0.6811 + 0.3938 -0.6176 -0.6808 + -48.4330 26.3254 13.6383) + #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo + 0.7581 0.4893 0.4311 + 0.6345 -0.4010 -0.6607 + -31.9784 -13.4285 44.9650) + #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo + -0.6890 0.5694 -0.4484 + 0.3694 -0.2564 -0.8932 + 12.1105 30.8774 46.0946) + #( 33.3400 11.0980 46.1750) ; P + #( 34.5130 10.2320 46.4660) ; O1P + #( 33.4130 12.3960 46.9340) ; O2P + #( 31.9810 10.3390 46.4820) ; O5* + #( 31.8779 9.9369 47.8760) ; C5* + #( 31.3239 10.6931 48.4322) ; H5* + #( 32.8647 9.6624 48.2489) ; H5** + #( 31.0429 8.6773 47.9401) ; C4* + #( 31.0779 8.2331 48.9349) ; H4* + #( 29.6956 8.9669 47.5983) ; O4* + #( 29.2784 8.1700 46.4782) ; C1* + #( 28.8006 7.2731 46.8722) ; H1* + #( 30.5544 7.7940 45.7875) ; C2* + #( 30.8837 8.6410 45.1856) ; H2** + #( 30.5100 6.6007 45.0582) ; O2* + #( 29.6694 6.4168 44.6326) ; H2* + #( 31.5146 7.5954 46.9527) ; C3* + #( 32.5255 7.8261 46.6166) ; H3* + #( 31.3876 6.2951 47.5516) ; O3* + #( 28.3976 8.9302 45.5933) ; N1 + #( 26.2155 9.6135 44.9910) ; N3 + #( 27.0281 8.8961 45.8192) ; C2 + #( 26.7044 10.3489 43.9595) ; C4 + #( 28.1088 10.3837 43.7247) ; C5 + #( 28.8978 9.6708 44.5535) ; C6 + #( 25.8715 11.0249 43.1749) ; N4 + #( 26.5733 8.2371 46.7484) ; O2 + #( 26.2707 11.5609 42.4177) ; H41 + #( 24.8760 10.9939 43.3427) ; H42 + #( 28.5089 10.9722 42.8990) ; H5 + #( 29.9782 9.6687 44.4097) ; H6 + )) + +(define rC09 + (make-constant-rC + #( 0.8727 0.4760 -0.1091 ; dgf-base-tfo + -0.4188 0.6148 -0.6682 + -0.2510 0.6289 0.7359 + -8.1687 -52.0761 -25.0726) + #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo + 0.0302 -0.7316 0.6811 + 0.3938 -0.6176 -0.6808 + -48.4330 26.3254 13.6383) + #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo + 0.7581 0.4893 0.4311 + 0.6345 -0.4010 -0.6607 + -31.9784 -13.4285 44.9650) + #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo + -0.6890 0.5694 -0.4484 + 0.3694 -0.2564 -0.8932 + 12.1105 30.8774 46.0946) + #( 33.3400 11.0980 46.1750) ; P + #( 34.5130 10.2320 46.4660) ; O1P + #( 33.4130 12.3960 46.9340) ; O2P + #( 31.9810 10.3390 46.4820) ; O5* + #( 30.8152 11.1619 46.2003) ; C5* + #( 30.4519 10.9454 45.1957) ; H5* + #( 31.0379 12.2016 46.4400) ; H5** + #( 29.7081 10.7448 47.1428) ; C4* + #( 29.4506 9.6945 47.0059) ; H4* + #( 30.1045 10.9634 48.4885) ; O4* + #( 29.1794 11.8418 49.1490) ; C1* + #( 28.4388 11.2210 49.6533) ; H1* + #( 28.5211 12.6008 48.0367) ; C2* + #( 29.1947 13.3949 47.7147) ; H2** + #( 27.2316 13.0683 48.3134) ; O2* + #( 27.0851 13.3391 49.2227) ; H2* + #( 28.4131 11.5507 46.9391) ; C3* + #( 28.4451 12.0512 45.9713) ; H3* + #( 27.2707 10.6955 47.1097) ; O3* + #( 29.8751 12.7405 50.0682) ; N1 + #( 30.7172 13.1841 52.2328) ; N3 + #( 30.0617 12.3404 51.3847) ; C2 + #( 31.1834 14.3941 51.8297) ; C4 + #( 30.9913 14.8074 50.4803) ; C5 + #( 30.3434 13.9610 49.6548) ; C6 + #( 31.8090 15.1847 52.6957) ; N4 + #( 29.6470 11.2494 51.7616) ; O2 + #( 32.1422 16.0774 52.3606) ; H41 + #( 31.9392 14.8893 53.6527) ; H42 + #( 31.3632 15.7771 50.1491) ; H5 + #( 30.1742 14.2374 48.6141) ; H6 + )) + +(define rC10 + (make-constant-rC + #( 0.1549 0.8710 -0.4663 ; dgf-base-tfo + 0.6768 -0.4374 -0.5921 + -0.7197 -0.2239 -0.6572 + 25.2447 -14.1920 50.3201) + #( 0.9187 0.2887 0.2694 ; P-O3*-275-tfo + 0.0302 -0.7316 0.6811 + 0.3938 -0.6176 -0.6808 + -48.4330 26.3254 13.6383) + #( -0.1504 0.7744 -0.6145 ; P-O3*-180-tfo + 0.7581 0.4893 0.4311 + 0.6345 -0.4010 -0.6607 + -31.9784 -13.4285 44.9650) + #( -0.6236 -0.7810 -0.0337 ; P-O3*-60-tfo + -0.6890 0.5694 -0.4484 + 0.3694 -0.2564 -0.8932 + 12.1105 30.8774 46.0946) + #( 33.3400 11.0980 46.1750) ; P + #( 34.5130 10.2320 46.4660) ; O1P + #( 33.4130 12.3960 46.9340) ; O2P + #( 31.9810 10.3390 46.4820) ; O5* + #( 31.8779 9.9369 47.8760) ; C5* + #( 31.3239 10.6931 48.4322) ; H5* + #( 32.8647 9.6624 48.2489) ; H5** + #( 31.0429 8.6773 47.9401) ; C4* + #( 30.0440 8.8473 47.5383) ; H4* + #( 31.6749 7.6351 47.2119) ; O4* + #( 31.9159 6.5022 48.0616) ; C1* + #( 31.0691 5.8243 47.9544) ; H1* + #( 31.9300 7.0685 49.4493) ; C2* + #( 32.9024 7.5288 49.6245) ; H2** + #( 31.5672 6.1750 50.4632) ; O2* + #( 31.8416 5.2663 50.3200) ; H2* + #( 30.8618 8.1514 49.3749) ; C3* + #( 31.1122 8.9396 50.0850) ; H3* + #( 29.5351 7.6245 49.5409) ; O3* + #( 33.1890 5.8629 47.7343) ; N1 + #( 34.4004 4.2636 46.4828) ; N3 + #( 33.2062 4.8497 46.7851) ; C2 + #( 35.5600 4.6374 47.0822) ; C4 + #( 35.5444 5.6751 48.0577) ; C5 + #( 34.3565 6.2450 48.3432) ; C6 + #( 36.6977 4.0305 46.7598) ; N4 + #( 32.1661 4.5034 46.2348) ; O2 + #( 37.5405 4.3347 47.2259) ; H41 + #( 36.7033 3.2923 46.0706) ; H42 + #( 36.4713 5.9811 48.5428) ; H5 + #( 34.2986 7.0426 49.0839) ; H6 + )) + +(define rCs + (list rC01 rC02 rC03 rC04 rC05 rC06 rC07 rC08 rC09 rC10)) + +(define rG + (make-constant-rG + #( -0.0018 -0.8207 0.5714 ; dgf-base-tfo + 0.2679 -0.5509 -0.7904 + 0.9634 0.1517 0.2209 + 0.0073 8.4030 0.6232) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 5.4550 8.2120 -2.8810) ; C5* + #( 5.4546 8.8508 -1.9978) ; H5* + #( 5.7588 8.6625 -3.8259) ; H5** + #( 6.4970 7.1480 -2.5980) ; C4* + #( 7.4896 7.5919 -2.5214) ; H4* + #( 6.1630 6.4860 -1.3440) ; O4* + #( 6.5400 5.1200 -1.4190) ; C1* + #( 7.2763 4.9681 -0.6297) ; H1* + #( 7.1940 4.8830 -2.7770) ; C2* + #( 6.8667 3.9183 -3.1647) ; H2** + #( 8.5860 5.0910 -2.6140) ; O2* + #( 8.9510 4.7626 -1.7890) ; H2* + #( 6.5720 6.0040 -3.6090) ; C3* + #( 5.5636 5.7066 -3.8966) ; H3* + #( 7.3801 6.3562 -4.7350) ; O3* + #( 4.7150 0.4910 -0.1360) ; N1 + #( 6.3490 2.1730 -0.6020) ; N3 + #( 5.9530 0.9650 -0.2670) ; C2 + #( 5.2900 2.9790 -0.8260) ; C4 + #( 3.9720 2.6390 -0.7330) ; C5 + #( 3.6770 1.3160 -0.3660) ; C6 + #( 6.8426 0.0056 -0.0019) ; N2 + #( 3.1660 3.7290 -1.0360) ; N7 + #( 5.3170 4.2990 -1.1930) ; N9 + #( 4.0100 4.6780 -1.2990) ; C8 + #( 2.4280 0.8450 -0.2360) ; O6 + #( 4.6151 -0.4677 0.1305) ; H1 + #( 6.6463 -0.9463 0.2729) ; H21 + #( 7.8170 0.2642 -0.0640) ; H22 + #( 3.4421 5.5744 -1.5482) ; H8 + )) + +(define rG01 + (make-constant-rG + #( -0.0043 -0.8175 0.5759 ; dgf-base-tfo + 0.2617 -0.5567 -0.7884 + 0.9651 0.1473 0.2164 + 0.0359 8.3929 0.5532) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 5.4352 8.2183 -2.7757) ; C5* + #( 5.3830 8.7883 -1.8481) ; H5* + #( 5.7729 8.7436 -3.6691) ; H5** + #( 6.4830 7.1518 -2.5252) ; C4* + #( 7.4749 7.5972 -2.4482) ; H4* + #( 6.1626 6.4620 -1.2827) ; O4* + #( 6.5431 5.0992 -1.3905) ; C1* + #( 7.2871 4.9328 -0.6114) ; H1* + #( 7.1852 4.8935 -2.7592) ; C2* + #( 6.8573 3.9363 -3.1645) ; H2** + #( 8.5780 5.1025 -2.6046) ; O2* + #( 8.9516 4.7577 -1.7902) ; H2* + #( 6.5522 6.0300 -3.5612) ; C3* + #( 5.5420 5.7356 -3.8459) ; H3* + #( 7.3487 6.4089 -4.6867) ; O3* + #( 4.7442 0.4514 -0.1390) ; N1 + #( 6.3687 2.1459 -0.5926) ; N3 + #( 5.9795 0.9335 -0.2657) ; C2 + #( 5.3052 2.9471 -0.8125) ; C4 + #( 3.9891 2.5987 -0.7230) ; C5 + #( 3.7016 1.2717 -0.3647) ; C6 + #( 6.8745 -0.0224 -0.0058) ; N2 + #( 3.1770 3.6859 -1.0198) ; N7 + #( 5.3247 4.2695 -1.1710) ; N9 + #( 4.0156 4.6415 -1.2759) ; C8 + #( 2.4553 0.7925 -0.2390) ; O6 + #( 4.6497 -0.5095 0.1212) ; H1 + #( 6.6836 -0.9771 0.2627) ; H21 + #( 7.8474 0.2424 -0.0653) ; H22 + #( 3.4426 5.5361 -1.5199) ; H8 + )) + +(define rG02 + (make-constant-rG + #( 0.5566 0.0449 0.8296 ; dgf-base-tfo + 0.5125 0.7673 -0.3854 + -0.6538 0.6397 0.4041 + -9.1161 -3.7679 -2.9968) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.5778 6.6594 -4.0364) ; C5* + #( 4.9220 7.1963 -4.9204) ; H5* + #( 3.7996 5.9091 -4.1764) ; H5** + #( 5.7873 5.8869 -3.5482) ; C4* + #( 6.0405 5.0875 -4.2446) ; H4* + #( 6.9135 6.8036 -3.4310) ; O4* + #( 7.7293 6.4084 -2.3392) ; C1* + #( 8.7078 6.1815 -2.7624) ; H1* + #( 7.1305 5.1418 -1.7347) ; C2* + #( 7.2040 5.1982 -0.6486) ; H2** + #( 7.7417 4.0392 -2.3813) ; O2* + #( 8.6785 4.1443 -2.5630) ; H2* + #( 5.6666 5.2728 -2.1536) ; C3* + #( 5.1747 5.9805 -1.4863) ; H3* + #( 4.9997 4.0086 -2.1973) ; O3* + #( 10.3245 8.5459 1.5467) ; N1 + #( 9.8051 6.9432 -0.1497) ; N3 + #( 10.5175 7.4328 0.8408) ; C2 + #( 8.7523 7.7422 -0.4228) ; C4 + #( 8.4257 8.9060 0.2099) ; C5 + #( 9.2665 9.3242 1.2540) ; C6 + #( 11.6077 6.7966 1.2752) ; N2 + #( 7.2750 9.4537 -0.3428) ; N7 + #( 7.7962 7.5519 -1.3859) ; N9 + #( 6.9479 8.6157 -1.2771) ; C8 + #( 9.0664 10.4462 1.9610) ; O6 + #( 10.9838 8.7524 2.2697) ; H1 + #( 12.2274 7.0896 2.0170) ; H21 + #( 11.8502 5.9398 0.7984) ; H22 + #( 6.0430 8.9853 -1.7594) ; H8 + )) + +(define rG03 + (make-constant-rG + #( -0.5021 0.0731 0.8617 ; dgf-base-tfo + -0.8112 0.3054 -0.4986 + -0.2996 -0.9494 -0.0940 + 6.4273 -5.1944 -3.7807) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.1214 6.7116 -1.9049) ; C5* + #( 3.3465 5.9610 -2.0607) ; H5* + #( 4.0789 7.2928 -0.9837) ; H5** + #( 5.4170 5.9293 -1.8186) ; C4* + #( 5.4506 5.3400 -0.9023) ; H4* + #( 5.5067 5.0417 -2.9703) ; O4* + #( 6.8650 4.9152 -3.3612) ; C1* + #( 7.1090 3.8577 -3.2603) ; H1* + #( 7.7152 5.7282 -2.3894) ; C2* + #( 8.5029 6.2356 -2.9463) ; H2** + #( 8.1036 4.8568 -1.3419) ; O2* + #( 8.3270 3.9651 -1.6184) ; H2* + #( 6.7003 6.7565 -1.8911) ; C3* + #( 6.5898 7.5329 -2.6482) ; H3* + #( 7.0505 7.2878 -0.6105) ; O3* + #( 9.6740 4.7656 -7.6614) ; N1 + #( 9.0739 4.3013 -5.3941) ; N3 + #( 9.8416 4.2192 -6.4581) ; C2 + #( 7.9885 5.0632 -5.6446) ; C4 + #( 7.6822 5.6856 -6.8194) ; C5 + #( 8.5831 5.5215 -7.8840) ; C6 + #( 10.9733 3.5117 -6.4286) ; N2 + #( 6.4857 6.3816 -6.7035) ; N7 + #( 6.9740 5.3703 -4.7760) ; N9 + #( 6.1133 6.1613 -5.4808) ; C8 + #( 8.4084 6.0747 -9.0933) ; O6 + #( 10.3759 4.5855 -8.3504) ; H1 + #( 11.6254 3.3761 -7.1879) ; H21 + #( 11.1917 3.0460 -5.5593) ; H22 + #( 5.1705 6.6830 -5.3167) ; H8 + )) + +(define rG04 + (make-constant-rG + #( -0.5426 -0.8175 0.1929 ; dgf-base-tfo + 0.8304 -0.5567 -0.0237 + 0.1267 0.1473 0.9809 + -0.5075 8.3929 0.2229) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 5.4352 8.2183 -2.7757) ; C5* + #( 5.3830 8.7883 -1.8481) ; H5* + #( 5.7729 8.7436 -3.6691) ; H5** + #( 6.4830 7.1518 -2.5252) ; C4* + #( 7.4749 7.5972 -2.4482) ; H4* + #( 6.1626 6.4620 -1.2827) ; O4* + #( 6.5431 5.0992 -1.3905) ; C1* + #( 7.2871 4.9328 -0.6114) ; H1* + #( 7.1852 4.8935 -2.7592) ; C2* + #( 6.8573 3.9363 -3.1645) ; H2** + #( 8.5780 5.1025 -2.6046) ; O2* + #( 8.9516 4.7577 -1.7902) ; H2* + #( 6.5522 6.0300 -3.5612) ; C3* + #( 5.5420 5.7356 -3.8459) ; H3* + #( 7.3487 6.4089 -4.6867) ; O3* + #( 3.6343 2.6680 2.0783) ; N1 + #( 5.4505 3.9805 1.2446) ; N3 + #( 4.7540 3.3816 2.1851) ; C2 + #( 4.8805 3.7951 0.0354) ; C4 + #( 3.7416 3.0925 -0.2305) ; C5 + #( 3.0873 2.4980 0.8606) ; C6 + #( 5.1433 3.4373 3.4609) ; N2 + #( 3.4605 3.1184 -1.5906) ; N7 + #( 5.3247 4.2695 -1.1710) ; N9 + #( 4.4244 3.8244 -2.0953) ; C8 + #( 1.9600 1.7805 0.7462) ; O6 + #( 3.2489 2.2879 2.9191) ; H1 + #( 4.6785 3.0243 4.2568) ; H21 + #( 5.9823 3.9654 3.6539) ; H22 + #( 4.2675 3.8876 -3.1721) ; H8 + )) + +(define rG05 + (make-constant-rG + #( -0.5891 0.0449 0.8068 ; dgf-base-tfo + 0.5375 0.7673 0.3498 + -0.6034 0.6397 -0.4762 + -0.3019 -3.7679 -9.5913) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.5778 6.6594 -4.0364) ; C5* + #( 4.9220 7.1963 -4.9204) ; H5* + #( 3.7996 5.9091 -4.1764) ; H5** + #( 5.7873 5.8869 -3.5482) ; C4* + #( 6.0405 5.0875 -4.2446) ; H4* + #( 6.9135 6.8036 -3.4310) ; O4* + #( 7.7293 6.4084 -2.3392) ; C1* + #( 8.7078 6.1815 -2.7624) ; H1* + #( 7.1305 5.1418 -1.7347) ; C2* + #( 7.2040 5.1982 -0.6486) ; H2** + #( 7.7417 4.0392 -2.3813) ; O2* + #( 8.6785 4.1443 -2.5630) ; H2* + #( 5.6666 5.2728 -2.1536) ; C3* + #( 5.1747 5.9805 -1.4863) ; H3* + #( 4.9997 4.0086 -2.1973) ; O3* + #( 10.2594 10.6774 -1.0056) ; N1 + #( 9.7528 8.7080 -2.2631) ; N3 + #( 10.4471 9.7876 -1.9791) ; C2 + #( 8.7271 8.5575 -1.3991) ; C4 + #( 8.4100 9.3803 -0.3580) ; C5 + #( 9.2294 10.5030 -0.1574) ; C6 + #( 11.5110 10.1256 -2.7114) ; N2 + #( 7.2891 8.9068 0.3121) ; N7 + #( 7.7962 7.5519 -1.3859) ; N9 + #( 6.9702 7.8292 -0.3353) ; C8 + #( 9.0349 11.3951 0.8250) ; O6 + #( 10.9013 11.4422 -0.9512) ; H1 + #( 12.1031 10.9341 -2.5861) ; H21 + #( 11.7369 9.5180 -3.4859) ; H22 + #( 6.0888 7.3990 0.1403) ; H8 + )) + +(define rG06 + (make-constant-rG + #( -0.9815 0.0731 -0.1772 ; dgf-base-tfo + 0.1912 0.3054 -0.9328 + -0.0141 -0.9494 -0.3137 + 5.7506 -5.1944 4.7470) + #( -0.8143 -0.5091 -0.2788 ; P-O3*-275-tfo + -0.0433 -0.4257 0.9038 + -0.5788 0.7480 0.3246 + 1.5227 6.9114 -7.0765) + #( 0.3822 -0.7477 0.5430 ; P-O3*-180-tfo + 0.4552 0.6637 0.5935 + -0.8042 0.0203 0.5941 + -6.9472 -4.1186 -5.9108) + #( 0.5640 0.8007 -0.2022 ; P-O3*-60-tfo + -0.8247 0.5587 -0.0878 + 0.0426 0.2162 0.9754 + 6.2694 -7.0540 3.3316) + #( 2.8930 8.5380 -3.3280) ; P + #( 1.6980 7.6960 -3.5570) ; O1P + #( 3.2260 9.5010 -4.4020) ; O2P + #( 4.1590 7.6040 -3.0340) ; O5* + #( 4.1214 6.7116 -1.9049) ; C5* + #( 3.3465 5.9610 -2.0607) ; H5* + #( 4.0789 7.2928 -0.9837) ; H5** + #( 5.4170 5.9293 -1.8186) ; C4* + #( 5.4506 5.3400 -0.9023) ; H4* + #( 5.5067 5.0417 -2.9703) ; O4* + #( 6.8650 4.9152 -3.3612) ; C1* + #( 7.1090 3.8577 -3.2603) ; H1* + #( 7.7152 5.7282 -2.3894) ; C2* + #( 8.5029 6.2356 -2.9463) ; H2** + #( 8.1036 4.8568 -1.3419) ; O2* + #( 8.3270 3.9651 -1.6184) ; H2* + #( 6.7003 6.7565 -1.8911) ; C3* + #( 6.5898 7.5329 -2.6482) ; H3* + #( 7.0505 7.2878 -0.6105) ; O3* + #( 6.6624 3.5061 -8.2986) ; N1 + #( 6.5810 3.2570 -5.9221) ; N3 + #( 6.5151 2.8263 -7.1625) ; C2 + #( 6.8364 4.5817 -5.8882) ; C4 + #( 7.0116 5.4064 -6.9609) ; C5 + #( 6.9173 4.8260 -8.2361) ; C6 + #( 6.2717 1.5402 -7.4250) ; N2 + #( 7.2573 6.7070 -6.5394) ; N7 + #( 6.9740 5.3703 -4.7760) ; N9 + #( 7.2238 6.6275 -5.2453) ; C8 + #( 7.0668 5.5163 -9.3763) ; O6 + #( 6.5754 2.9964 -9.1545) ; H1 + #( 6.1908 1.1105 -8.3354) ; H21 + #( 6.1346 0.9352 -6.6280) ; H22 + #( 7.4108 7.6227 -4.8418) ; H8 + )) + +(define rG07 + (make-constant-rG + #( 0.0894 -0.6059 0.7905 ; dgf-base-tfo + -0.6810 0.5420 0.4924 + -0.7268 -0.5824 -0.3642 + 34.1424 45.9610 -11.8600) + #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo + -0.0427 0.2409 -0.9696 + 0.5010 -0.8345 -0.2294 + 4.0167 54.5377 12.4779) + #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo + -0.2867 -0.7872 -0.5460 + 0.8834 0.0032 -0.4686 + -52.9020 18.6313 -0.6709) + #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo + 0.9040 -0.4236 -0.0582 + -0.1007 -0.0786 -0.9918 + -7.6624 -25.2080 49.5181) + #( 31.3810 0.1400 47.5810) ; P + #( 29.9860 0.6630 47.6290) ; O1P + #( 31.7210 -0.6460 48.8090) ; O2P + #( 32.4940 1.2540 47.2740) ; O5* + #( 33.8709 0.7918 47.2113) ; C5* + #( 34.1386 0.5870 46.1747) ; H5* + #( 34.0186 -0.0095 47.9353) ; H5** + #( 34.7297 1.9687 47.6685) ; C4* + #( 35.7723 1.6845 47.8113) ; H4* + #( 34.6455 2.9768 46.6660) ; O4* + #( 34.1690 4.1829 47.2627) ; C1* + #( 35.0437 4.7633 47.5560) ; H1* + #( 33.4145 3.7532 48.4954) ; C2* + #( 32.4340 3.3797 48.2001) ; H2** + #( 33.3209 4.6953 49.5217) ; O2* + #( 33.2374 5.6059 49.2295) ; H2* + #( 34.2724 2.5970 48.9773) ; C3* + #( 33.6373 1.8935 49.5157) ; H3* + #( 35.3453 3.1884 49.7285) ; O3* + #( 34.0511 7.8930 43.7791) ; N1 + #( 34.9937 6.3369 45.3199) ; N3 + #( 35.0882 7.3126 44.4200) ; C2 + #( 33.7190 5.9650 45.5374) ; C4 + #( 32.5845 6.4770 44.9458) ; C5 + #( 32.7430 7.5179 43.9914) ; C6 + #( 36.3030 7.7827 44.1036) ; N2 + #( 31.4499 5.8335 45.4368) ; N7 + #( 33.2760 4.9817 46.4043) ; N9 + #( 31.9235 4.9639 46.2934) ; C8 + #( 31.8602 8.1000 43.3695) ; O6 + #( 34.2623 8.6223 43.1283) ; H1 + #( 36.5188 8.5081 43.4347) ; H21 + #( 37.0888 7.3524 44.5699) ; H22 + #( 31.0815 4.4201 46.7218) ; H8 + )) + +(define rG08 + (make-constant-rG + #( 0.2224 0.6335 0.7411 ; dgf-base-tfo + -0.3644 -0.6510 0.6659 + 0.9043 -0.4181 0.0861 + -47.6824 -0.5823 -31.7554) + #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo + -0.0427 0.2409 -0.9696 + 0.5010 -0.8345 -0.2294 + 4.0167 54.5377 12.4779) + #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo + -0.2867 -0.7872 -0.5460 + 0.8834 0.0032 -0.4686 + -52.9020 18.6313 -0.6709) + #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo + 0.9040 -0.4236 -0.0582 + -0.1007 -0.0786 -0.9918 + -7.6624 -25.2080 49.5181) + #( 31.3810 0.1400 47.5810) ; P + #( 29.9860 0.6630 47.6290) ; O1P + #( 31.7210 -0.6460 48.8090) ; O2P + #( 32.4940 1.2540 47.2740) ; O5* + #( 32.5924 2.3488 48.2255) ; C5* + #( 33.3674 2.1246 48.9584) ; H5* + #( 31.5994 2.5917 48.6037) ; H5** + #( 33.0722 3.5577 47.4258) ; C4* + #( 33.0310 4.4778 48.0089) ; H4* + #( 34.4173 3.3055 47.0316) ; O4* + #( 34.5056 3.3910 45.6094) ; C1* + #( 34.7881 4.4152 45.3663) ; H1* + #( 33.1122 3.1198 45.1010) ; C2* + #( 32.9230 2.0469 45.1369) ; H2** + #( 32.7946 3.6590 43.8529) ; O2* + #( 33.5170 3.6707 43.2207) ; H2* + #( 32.2730 3.8173 46.1566) ; C3* + #( 31.3094 3.3123 46.2244) ; H3* + #( 32.2391 5.2039 45.7807) ; O3* + #( 39.3337 2.7157 44.1441) ; N1 + #( 37.4430 3.8242 45.0824) ; N3 + #( 38.7276 3.7646 44.7403) ; C2 + #( 36.7791 2.6963 44.7704) ; C4 + #( 37.2860 1.5653 44.1678) ; C5 + #( 38.6647 1.5552 43.8235) ; C6 + #( 39.5123 4.8216 44.9936) ; N2 + #( 36.2829 0.6110 44.0078) ; N7 + #( 35.4394 2.4314 44.9931) ; N9 + #( 35.2180 1.1815 44.5128) ; C8 + #( 39.2907 0.6514 43.2796) ; O6 + #( 40.3076 2.8048 43.9352) ; H1 + #( 40.4994 4.9066 44.7977) ; H21 + #( 39.0738 5.6108 45.4464) ; H22 + #( 34.3856 0.4842 44.4185) ; H8 + )) + +(define rG09 + (make-constant-rG + #( -0.9699 -0.1688 -0.1753 ; dgf-base-tfo + -0.1050 -0.3598 0.9271 + -0.2196 0.9176 0.3312 + 45.6217 -38.9484 -12.3208) + #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo + -0.0427 0.2409 -0.9696 + 0.5010 -0.8345 -0.2294 + 4.0167 54.5377 12.4779) + #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo + -0.2867 -0.7872 -0.5460 + 0.8834 0.0032 -0.4686 + -52.9020 18.6313 -0.6709) + #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo + 0.9040 -0.4236 -0.0582 + -0.1007 -0.0786 -0.9918 + -7.6624 -25.2080 49.5181) + #( 31.3810 0.1400 47.5810) ; P + #( 29.9860 0.6630 47.6290) ; O1P + #( 31.7210 -0.6460 48.8090) ; O2P + #( 32.4940 1.2540 47.2740) ; O5* + #( 33.8709 0.7918 47.2113) ; C5* + #( 34.1386 0.5870 46.1747) ; H5* + #( 34.0186 -0.0095 47.9353) ; H5** + #( 34.7297 1.9687 47.6685) ; C4* + #( 34.5880 2.8482 47.0404) ; H4* + #( 34.3575 2.2770 49.0081) ; O4* + #( 35.5157 2.1993 49.8389) ; C1* + #( 35.9424 3.2010 49.8893) ; H1* + #( 36.4701 1.2820 49.1169) ; C2* + #( 36.1545 0.2498 49.2683) ; H2** + #( 37.8262 1.4547 49.4008) ; O2* + #( 38.0227 1.6945 50.3094) ; H2* + #( 36.2242 1.6797 47.6725) ; C3* + #( 36.4297 0.8197 47.0351) ; H3* + #( 37.0289 2.8480 47.4426) ; O3* + #( 34.3005 3.5042 54.6070) ; N1 + #( 34.7693 3.7936 52.2874) ; N3 + #( 34.4484 4.2541 53.4939) ; C2 + #( 34.9354 2.4584 52.2785) ; C4 + #( 34.8092 1.5915 53.3422) ; C5 + #( 34.4646 2.1367 54.6085) ; C6 + #( 34.2514 5.5708 53.6503) ; N2 + #( 35.0641 0.2835 52.9337) ; N7 + #( 35.2669 1.6690 51.1915) ; N9 + #( 35.3288 0.3954 51.6563) ; C8 + #( 34.3151 1.5317 55.6650) ; O6 + #( 34.0623 3.9797 55.4539) ; H1 + #( 33.9950 6.0502 54.5016) ; H21 + #( 34.3512 6.1432 52.8242) ; H22 + #( 35.5414 -0.6006 51.2679) ; H8 + )) + +(define rG10 + (make-constant-rG + #( -0.0980 -0.9723 0.2122 ; dgf-base-tfo + -0.9731 0.1383 0.1841 + -0.2083 -0.1885 -0.9597 + 17.8469 38.8265 37.0475) + #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo + -0.0427 0.2409 -0.9696 + 0.5010 -0.8345 -0.2294 + 4.0167 54.5377 12.4779) + #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo + -0.2867 -0.7872 -0.5460 + 0.8834 0.0032 -0.4686 + -52.9020 18.6313 -0.6709) + #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo + 0.9040 -0.4236 -0.0582 + -0.1007 -0.0786 -0.9918 + -7.6624 -25.2080 49.5181) + #( 31.3810 0.1400 47.5810) ; P + #( 29.9860 0.6630 47.6290) ; O1P + #( 31.7210 -0.6460 48.8090) ; O2P + #( 32.4940 1.2540 47.2740) ; O5* + #( 32.5924 2.3488 48.2255) ; C5* + #( 33.3674 2.1246 48.9584) ; H5* + #( 31.5994 2.5917 48.6037) ; H5** + #( 33.0722 3.5577 47.4258) ; C4* + #( 34.0333 3.3761 46.9447) ; H4* + #( 32.0890 3.8338 46.4332) ; O4* + #( 31.6377 5.1787 46.5914) ; C1* + #( 32.2499 5.8016 45.9392) ; H1* + #( 31.9167 5.5319 48.0305) ; C2* + #( 31.1507 5.0820 48.6621) ; H2** + #( 32.0865 6.8890 48.3114) ; O2* + #( 31.5363 7.4819 47.7942) ; H2* + #( 33.2398 4.8224 48.2563) ; C3* + #( 33.3166 4.5570 49.3108) ; H3* + #( 34.2528 5.7056 47.7476) ; O3* + #( 28.2782 6.3049 42.9364) ; N1 + #( 30.4001 5.8547 43.9258) ; N3 + #( 29.6195 6.1568 42.8913) ; C2 + #( 29.7005 5.7006 45.0649) ; C4 + #( 28.3383 5.8221 45.2343) ; C5 + #( 27.5519 6.1461 44.0958) ; C6 + #( 30.1838 6.3385 41.6890) ; N2 + #( 27.9936 5.5926 46.5651) ; N7 + #( 30.2046 5.3825 46.3136) ; N9 + #( 29.1371 5.3398 47.1506) ; C8 + #( 26.3361 6.3024 44.0495) ; O6 + #( 27.8122 6.5394 42.0833) ; H1 + #( 29.7125 6.5595 40.8235) ; H21 + #( 31.1859 6.2231 41.6389) ; H22 + #( 28.9406 5.1504 48.2059) ; H8 + )) + +(define rGs + (list rG01 rG02 rG03 rG04 rG05 rG06 rG07 rG08 rG09 rG10)) + +(define rU + (make-constant-rU + #( -0.0359 -0.8071 0.5894 ; dgf-base-tfo + -0.2669 0.5761 0.7726 + -0.9631 -0.1296 -0.2361 + 0.1584 8.3434 0.5434) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 5.2430 -8.2420 2.8260) ; C5* + #( 5.1974 -8.8497 1.9223) ; H5* + #( 5.5548 -8.7348 3.7469) ; H5** + #( 6.3140 -7.2060 2.5510) ; C4* + #( 7.2954 -7.6762 2.4898) ; H4* + #( 6.0140 -6.5420 1.2890) ; O4* + #( 6.4190 -5.1840 1.3620) ; C1* + #( 7.1608 -5.0495 0.5747) ; H1* + #( 7.0760 -4.9560 2.7270) ; C2* + #( 6.7770 -3.9803 3.1099) ; H2** + #( 8.4500 -5.1930 2.5810) ; O2* + #( 8.8309 -4.8755 1.7590) ; H2* + #( 6.4060 -6.0590 3.5580) ; C3* + #( 5.4021 -5.7313 3.8281) ; H3* + #( 7.1570 -6.4240 4.7070) ; O3* + #( 5.2170 -4.3260 1.1690) ; N1 + #( 4.2960 -2.2560 0.6290) ; N3 + #( 5.4330 -3.0200 0.7990) ; C2 + #( 2.9930 -2.6780 0.7940) ; C4 + #( 2.8670 -4.0630 1.1830) ; C5 + #( 3.9570 -4.8300 1.3550) ; C6 + #( 6.5470 -2.5560 0.6290) ; O2 + #( 2.0540 -1.9000 0.6130) ; O4 + #( 4.4300 -1.3020 0.3600) ; H3 + #( 1.9590 -4.4570 1.3250) ; H5 + #( 3.8460 -5.7860 1.6240) ; H6 + )) + +(define rU01 + (make-constant-rU + #( -0.0137 -0.8012 0.5983 ; dgf-base-tfo + -0.2523 0.5817 0.7733 + -0.9675 -0.1404 -0.2101 + 0.2031 8.3874 0.4228) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 5.2416 -8.2422 2.8181) ; C5* + #( 5.2050 -8.8128 1.8901) ; H5* + #( 5.5368 -8.7738 3.7227) ; H5** + #( 6.3232 -7.2037 2.6002) ; C4* + #( 7.3048 -7.6757 2.5577) ; H4* + #( 6.0635 -6.5092 1.3456) ; O4* + #( 6.4697 -5.1547 1.4629) ; C1* + #( 7.2354 -5.0043 0.7018) ; H1* + #( 7.0856 -4.9610 2.8521) ; C2* + #( 6.7777 -3.9935 3.2487) ; H2** + #( 8.4627 -5.1992 2.7423) ; O2* + #( 8.8693 -4.8638 1.9399) ; H2* + #( 6.3877 -6.0809 3.6362) ; C3* + #( 5.3770 -5.7562 3.8834) ; H3* + #( 7.1024 -6.4754 4.7985) ; O3* + #( 5.2764 -4.2883 1.2538) ; N1 + #( 4.3777 -2.2062 0.7229) ; N3 + #( 5.5069 -2.9779 0.9088) ; C2 + #( 3.0693 -2.6246 0.8500) ; C4 + #( 2.9279 -4.0146 1.2149) ; C5 + #( 4.0101 -4.7892 1.4017) ; C6 + #( 6.6267 -2.5166 0.7728) ; O2 + #( 2.1383 -1.8396 0.6581) ; O4 + #( 4.5223 -1.2489 0.4716) ; H3 + #( 2.0151 -4.4065 1.3290) ; H5 + #( 3.8886 -5.7486 1.6535) ; H6 + )) + +(define rU02 + (make-constant-rU + #( 0.5141 0.0246 0.8574 ; dgf-base-tfo + -0.5547 -0.7529 0.3542 + 0.6542 -0.6577 -0.3734 + -9.1111 -3.4598 -3.2939) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 4.3825 -6.6585 4.0489) ; C5* + #( 4.6841 -7.2019 4.9443) ; H5* + #( 3.6189 -5.8889 4.1625) ; H5** + #( 5.6255 -5.9175 3.5998) ; C4* + #( 5.8732 -5.1228 4.3034) ; H4* + #( 6.7337 -6.8605 3.5222) ; O4* + #( 7.5932 -6.4923 2.4548) ; C1* + #( 8.5661 -6.2983 2.9064) ; H1* + #( 7.0527 -5.2012 1.8322) ; C2* + #( 7.1627 -5.2525 0.7490) ; H2** + #( 7.6666 -4.1249 2.4880) ; O2* + #( 8.5944 -4.2543 2.6981) ; H2* + #( 5.5661 -5.3029 2.2009) ; C3* + #( 5.0841 -6.0018 1.5172) ; H3* + #( 4.9062 -4.0452 2.2042) ; O3* + #( 7.6298 -7.6136 1.4752) ; N1 + #( 8.6945 -8.7046 -0.2857) ; N3 + #( 8.6943 -7.6514 0.6066) ; C2 + #( 7.7426 -9.6987 -0.3801) ; C4 + #( 6.6642 -9.5742 0.5722) ; C5 + #( 6.6391 -8.5592 1.4526) ; C6 + #( 9.5840 -6.8186 0.6136) ; O2 + #( 7.8505 -10.5925 -1.2223) ; O4 + #( 9.4601 -8.7514 -0.9277) ; H3 + #( 5.9281 -10.2509 0.5782) ; H5 + #( 5.8831 -8.4931 2.1028) ; H6 + )) + +(define rU03 + (make-constant-rU + #( -0.4993 0.0476 0.8651 ; dgf-base-tfo + 0.8078 -0.3353 0.4847 + 0.3132 0.9409 0.1290 + 6.2989 -5.2303 -3.8577) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 3.9938 -6.7042 1.9023) ; C5* + #( 3.2332 -5.9343 2.0319) ; H5* + #( 3.9666 -7.2863 0.9812) ; H5** + #( 5.3098 -5.9546 1.8564) ; C4* + #( 5.3863 -5.3702 0.9395) ; H4* + #( 5.3851 -5.0642 3.0076) ; O4* + #( 6.7315 -4.9724 3.4462) ; C1* + #( 7.0033 -3.9202 3.3619) ; H1* + #( 7.5997 -5.8018 2.4948) ; C2* + #( 8.3627 -6.3254 3.0707) ; H2** + #( 8.0410 -4.9501 1.4724) ; O2* + #( 8.2781 -4.0644 1.7570) ; H2* + #( 6.5701 -6.8129 1.9714) ; C3* + #( 6.4186 -7.5809 2.7299) ; H3* + #( 6.9357 -7.3841 0.7235) ; O3* + #( 6.8024 -5.4718 4.8475) ; N1 + #( 7.9218 -5.5700 6.8877) ; N3 + #( 7.8908 -5.0886 5.5944) ; C2 + #( 6.9789 -6.3827 7.4823) ; C4 + #( 5.8742 -6.7319 6.6202) ; C5 + #( 5.8182 -6.2769 5.3570) ; C6 + #( 8.7747 -4.3728 5.1568) ; O2 + #( 7.1154 -6.7509 8.6509) ; O4 + #( 8.7055 -5.3037 7.4491) ; H3 + #( 5.1416 -7.3178 6.9665) ; H5 + #( 5.0441 -6.5310 4.7784) ; H6 + )) + +(define rU04 + (make-constant-rU + #( -0.5669 -0.8012 0.1918 ; dgf-base-tfo + -0.8129 0.5817 0.0273 + -0.1334 -0.1404 -0.9811 + -0.3279 8.3874 0.3355) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 5.2416 -8.2422 2.8181) ; C5* + #( 5.2050 -8.8128 1.8901) ; H5* + #( 5.5368 -8.7738 3.7227) ; H5** + #( 6.3232 -7.2037 2.6002) ; C4* + #( 7.3048 -7.6757 2.5577) ; H4* + #( 6.0635 -6.5092 1.3456) ; O4* + #( 6.4697 -5.1547 1.4629) ; C1* + #( 7.2354 -5.0043 0.7018) ; H1* + #( 7.0856 -4.9610 2.8521) ; C2* + #( 6.7777 -3.9935 3.2487) ; H2** + #( 8.4627 -5.1992 2.7423) ; O2* + #( 8.8693 -4.8638 1.9399) ; H2* + #( 6.3877 -6.0809 3.6362) ; C3* + #( 5.3770 -5.7562 3.8834) ; H3* + #( 7.1024 -6.4754 4.7985) ; O3* + #( 5.2764 -4.2883 1.2538) ; N1 + #( 3.8961 -3.0896 -0.1893) ; N3 + #( 5.0095 -3.8907 -0.0346) ; C2 + #( 3.0480 -2.6632 0.8116) ; C4 + #( 3.4093 -3.1310 2.1292) ; C5 + #( 4.4878 -3.9124 2.3088) ; C6 + #( 5.7005 -4.2164 -0.9842) ; O2 + #( 2.0800 -1.9458 0.5503) ; O4 + #( 3.6834 -2.7882 -1.1190) ; H3 + #( 2.8508 -2.8721 2.9172) ; H5 + #( 4.7188 -4.2247 3.2295) ; H6 + )) + +(define rU05 + (make-constant-rU + #( -0.6298 0.0246 0.7763 ; dgf-base-tfo + -0.5226 -0.7529 -0.4001 + 0.5746 -0.6577 0.4870 + -0.0208 -3.4598 -9.6882) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 4.3825 -6.6585 4.0489) ; C5* + #( 4.6841 -7.2019 4.9443) ; H5* + #( 3.6189 -5.8889 4.1625) ; H5** + #( 5.6255 -5.9175 3.5998) ; C4* + #( 5.8732 -5.1228 4.3034) ; H4* + #( 6.7337 -6.8605 3.5222) ; O4* + #( 7.5932 -6.4923 2.4548) ; C1* + #( 8.5661 -6.2983 2.9064) ; H1* + #( 7.0527 -5.2012 1.8322) ; C2* + #( 7.1627 -5.2525 0.7490) ; H2** + #( 7.6666 -4.1249 2.4880) ; O2* + #( 8.5944 -4.2543 2.6981) ; H2* + #( 5.5661 -5.3029 2.2009) ; C3* + #( 5.0841 -6.0018 1.5172) ; H3* + #( 4.9062 -4.0452 2.2042) ; O3* + #( 7.6298 -7.6136 1.4752) ; N1 + #( 8.5977 -9.5977 0.7329) ; N3 + #( 8.5951 -8.5745 1.6594) ; C2 + #( 7.7372 -9.7371 -0.3364) ; C4 + #( 6.7596 -8.6801 -0.4476) ; C5 + #( 6.7338 -7.6721 0.4408) ; C6 + #( 9.3993 -8.5377 2.5743) ; O2 + #( 7.8374 -10.6990 -1.1008) ; O4 + #( 9.2924 -10.3081 0.8477) ; H3 + #( 6.0932 -8.6982 -1.1929) ; H5 + #( 6.0481 -6.9515 0.3446) ; H6 + )) + +(define rU06 + (make-constant-rU + #( -0.9837 0.0476 -0.1733 ; dgf-base-tfo + -0.1792 -0.3353 0.9249 + -0.0141 0.9409 0.3384 + 5.7793 -5.2303 4.5997) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 3.9938 -6.7042 1.9023) ; C5* + #( 3.2332 -5.9343 2.0319) ; H5* + #( 3.9666 -7.2863 0.9812) ; H5** + #( 5.3098 -5.9546 1.8564) ; C4* + #( 5.3863 -5.3702 0.9395) ; H4* + #( 5.3851 -5.0642 3.0076) ; O4* + #( 6.7315 -4.9724 3.4462) ; C1* + #( 7.0033 -3.9202 3.3619) ; H1* + #( 7.5997 -5.8018 2.4948) ; C2* + #( 8.3627 -6.3254 3.0707) ; H2** + #( 8.0410 -4.9501 1.4724) ; O2* + #( 8.2781 -4.0644 1.7570) ; H2* + #( 6.5701 -6.8129 1.9714) ; C3* + #( 6.4186 -7.5809 2.7299) ; H3* + #( 6.9357 -7.3841 0.7235) ; O3* + #( 6.8024 -5.4718 4.8475) ; N1 + #( 6.6920 -5.0495 7.1354) ; N3 + #( 6.6201 -4.5500 5.8506) ; C2 + #( 6.9254 -6.3614 7.4926) ; C4 + #( 7.1046 -7.2543 6.3718) ; C5 + #( 7.0391 -6.7951 5.1106) ; C6 + #( 6.4083 -3.3696 5.6340) ; O2 + #( 6.9679 -6.6901 8.6800) ; O4 + #( 6.5626 -4.3957 7.8812) ; H3 + #( 7.2781 -8.2254 6.5350) ; H5 + #( 7.1657 -7.4312 4.3503) ; H6 + )) + +(define rU07 + (make-constant-rU + #( -0.9434 0.3172 0.0971 ; dgf-base-tfo + 0.2294 0.4125 0.8816 + 0.2396 0.8539 -0.4619 + 8.3625 -52.7147 1.3745) + #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo + -0.8297 0.4733 -0.2959 + 0.4850 0.8737 0.0379 + -14.7774 -45.2464 21.9088) + #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo + -0.5932 -0.6591 0.4624 + -0.7980 0.4055 -0.4458 + 43.7634 4.3296 28.4890) + #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo + 0.6803 0.3317 0.6536 + -0.1673 -0.7979 0.5791 + -17.1858 41.4390 -27.0751) + #( 21.3880 15.0780 45.5770) ; P + #( 21.9980 14.5500 46.8210) ; O1P + #( 21.1450 14.0270 44.5420) ; O2P + #( 22.1250 16.3600 44.9460) ; O5* + #( 21.5037 16.8594 43.7323) ; C5* + #( 20.8147 17.6663 43.9823) ; H5* + #( 21.1086 16.0230 43.1557) ; H5** + #( 22.5654 17.4874 42.8616) ; C4* + #( 22.1584 17.7243 41.8785) ; H4* + #( 23.0557 18.6826 43.4751) ; O4* + #( 24.4788 18.6151 43.6455) ; C1* + #( 24.9355 19.0840 42.7739) ; H1* + #( 24.7958 17.1427 43.6474) ; C2* + #( 24.5652 16.7400 44.6336) ; H2** + #( 26.1041 16.8773 43.2455) ; O2* + #( 26.7516 17.5328 43.5149) ; H2* + #( 23.8109 16.5979 42.6377) ; C3* + #( 23.5756 15.5686 42.9084) ; H3* + #( 24.2890 16.7447 41.2729) ; O3* + #( 24.9420 19.2174 44.8923) ; N1 + #( 25.2655 20.5636 44.8883) ; N3 + #( 25.1663 21.2219 43.8561) ; C2 + #( 25.6911 21.1219 46.0494) ; C4 + #( 25.8051 20.4068 47.2048) ; C5 + #( 26.2093 20.9962 48.2534) ; C6 + #( 25.4692 19.0221 47.2053) ; O2 + #( 25.0502 18.4827 46.0370) ; O4 + #( 25.9599 22.1772 46.0966) ; H3 + #( 25.5545 18.4409 48.1234) ; H5 + #( 24.7854 17.4265 45.9883) ; H6 + )) + +(define rU08 + (make-constant-rU + #( -0.0080 -0.7928 0.6094 ; dgf-base-tfo + -0.7512 0.4071 0.5197 + -0.6601 -0.4536 -0.5988 + 44.1482 30.7036 2.1088) + #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo + -0.8297 0.4733 -0.2959 + 0.4850 0.8737 0.0379 + -14.7774 -45.2464 21.9088) + #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo + -0.5932 -0.6591 0.4624 + -0.7980 0.4055 -0.4458 + 43.7634 4.3296 28.4890) + #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo + 0.6803 0.3317 0.6536 + -0.1673 -0.7979 0.5791 + -17.1858 41.4390 -27.0751) + #( 21.3880 15.0780 45.5770) ; P + #( 21.9980 14.5500 46.8210) ; O1P + #( 21.1450 14.0270 44.5420) ; O2P + #( 22.1250 16.3600 44.9460) ; O5* + #( 23.5096 16.1227 44.5783) ; C5* + #( 23.5649 15.8588 43.5222) ; H5* + #( 23.9621 15.4341 45.2919) ; H5** + #( 24.2805 17.4138 44.7151) ; C4* + #( 25.3492 17.2309 44.6030) ; H4* + #( 23.8497 18.3471 43.7208) ; O4* + #( 23.4090 19.5681 44.3321) ; C1* + #( 24.2595 20.2496 44.3524) ; H1* + #( 23.0418 19.1813 45.7407) ; C2* + #( 22.0532 18.7224 45.7273) ; H2** + #( 23.1307 20.2521 46.6291) ; O2* + #( 22.8888 21.1051 46.2611) ; H2* + #( 24.0799 18.1326 46.0700) ; C3* + #( 23.6490 17.4370 46.7900) ; H3* + #( 25.3329 18.7227 46.5109) ; O3* + #( 22.2515 20.1624 43.6698) ; N1 + #( 22.4760 21.0609 42.6406) ; N3 + #( 23.6229 21.3462 42.3061) ; C2 + #( 21.3986 21.6081 42.0236) ; C4 + #( 20.1189 21.3012 42.3804) ; C5 + #( 19.1599 21.8516 41.7578) ; C6 + #( 19.8919 20.3745 43.4387) ; O2 + #( 20.9790 19.8423 44.0440) ; O4 + #( 21.5235 22.3222 41.2097) ; H3 + #( 18.8732 20.1200 43.7312) ; H5 + #( 20.8545 19.1313 44.8608) ; H6 + )) + +(define rU09 + (make-constant-rU + #( -0.0317 0.1374 0.9900 ; dgf-base-tfo + -0.3422 -0.9321 0.1184 + 0.9391 -0.3351 0.0765 + -32.1929 25.8198 -28.5088) + #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo + -0.8297 0.4733 -0.2959 + 0.4850 0.8737 0.0379 + -14.7774 -45.2464 21.9088) + #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo + -0.5932 -0.6591 0.4624 + -0.7980 0.4055 -0.4458 + 43.7634 4.3296 28.4890) + #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo + 0.6803 0.3317 0.6536 + -0.1673 -0.7979 0.5791 + -17.1858 41.4390 -27.0751) + #( 21.3880 15.0780 45.5770) ; P + #( 21.9980 14.5500 46.8210) ; O1P + #( 21.1450 14.0270 44.5420) ; O2P + #( 22.1250 16.3600 44.9460) ; O5* + #( 21.5037 16.8594 43.7323) ; C5* + #( 20.8147 17.6663 43.9823) ; H5* + #( 21.1086 16.0230 43.1557) ; H5** + #( 22.5654 17.4874 42.8616) ; C4* + #( 23.0565 18.3036 43.3915) ; H4* + #( 23.5375 16.5054 42.4925) ; O4* + #( 23.6574 16.4257 41.0649) ; C1* + #( 24.4701 17.0882 40.7671) ; H1* + #( 22.3525 16.9643 40.5396) ; C2* + #( 21.5993 16.1799 40.6133) ; H2** + #( 22.4693 17.4849 39.2515) ; O2* + #( 23.0899 17.0235 38.6827) ; H2* + #( 22.0341 18.0633 41.5279) ; C3* + #( 20.9509 18.1709 41.5846) ; H3* + #( 22.7249 19.3020 41.2100) ; O3* + #( 23.8580 15.0648 40.5757) ; N1 + #( 25.1556 14.5982 40.4523) ; N3 + #( 26.1047 15.3210 40.7448) ; C2 + #( 25.3391 13.3315 40.0020) ; C4 + #( 24.2974 12.5148 39.6749) ; C5 + #( 24.5450 11.3410 39.2610) ; C6 + #( 22.9633 12.9979 39.8053) ; O2 + #( 22.8009 14.2648 40.2524) ; O4 + #( 26.3414 12.9194 39.8855) ; H3 + #( 22.1227 12.3533 39.5486) ; H5 + #( 21.7989 14.6788 40.3650) ; H6 + )) + +(define rU10 + (make-constant-rU + #( -0.9674 0.1021 -0.2318 ; dgf-base-tfo + -0.2514 -0.2766 0.9275 + 0.0306 0.9555 0.2933 + 27.8571 -42.1305 -24.4563) + #( 0.2765 -0.1121 -0.9545 ; P-O3*-275-tfo + -0.8297 0.4733 -0.2959 + 0.4850 0.8737 0.0379 + -14.7774 -45.2464 21.9088) + #( 0.1063 -0.6334 -0.7665 ; P-O3*-180-tfo + -0.5932 -0.6591 0.4624 + -0.7980 0.4055 -0.4458 + 43.7634 4.3296 28.4890) + #( 0.7136 -0.5032 -0.4873 ; P-O3*-60-tfo + 0.6803 0.3317 0.6536 + -0.1673 -0.7979 0.5791 + -17.1858 41.4390 -27.0751) + #( 21.3880 15.0780 45.5770) ; P + #( 21.9980 14.5500 46.8210) ; O1P + #( 21.1450 14.0270 44.5420) ; O2P + #( 22.1250 16.3600 44.9460) ; O5* + #( 23.5096 16.1227 44.5783) ; C5* + #( 23.5649 15.8588 43.5222) ; H5* + #( 23.9621 15.4341 45.2919) ; H5** + #( 24.2805 17.4138 44.7151) ; C4* + #( 23.8509 18.1819 44.0720) ; H4* + #( 24.2506 17.8583 46.0741) ; O4* + #( 25.5830 18.0320 46.5775) ; C1* + #( 25.8569 19.0761 46.4256) ; H1* + #( 26.4410 17.1555 45.7033) ; C2* + #( 26.3459 16.1253 46.0462) ; H2** + #( 27.7649 17.5888 45.6478) ; O2* + #( 28.1004 17.9719 46.4616) ; H2* + #( 25.7796 17.2997 44.3513) ; C3* + #( 25.9478 16.3824 43.7871) ; H3* + #( 26.2154 18.4984 43.6541) ; O3* + #( 25.7321 17.6281 47.9726) ; N1 + #( 25.5136 18.5779 48.9560) ; N3 + #( 25.2079 19.7276 48.6503) ; C2 + #( 25.6482 18.1987 50.2518) ; C4 + #( 25.9847 16.9266 50.6092) ; C5 + #( 26.0918 16.6439 51.8416) ; C6 + #( 26.2067 15.9515 49.5943) ; O2 + #( 26.0713 16.3497 48.3080) ; O4 + #( 25.4890 18.9105 51.0618) ; H3 + #( 26.4742 14.9310 49.8682) ; H5 + #( 26.2346 15.6394 47.4975) ; H6 + )) + +(define rUs + (list rU01 rU02 rU03 rU04 rU05 rU06 rU07 rU08 rU09 rU10)) + +(define rG* + (make-constant-rG + #( -0.2067 -0.0264 0.9780 ; dgf-base-tfo + 0.9770 -0.0586 0.2049 + 0.0519 0.9979 0.0379 + 1.0331 -46.8078 -36.4742) + #( -0.8644 -0.4956 -0.0851 ; P-O3*-275-tfo + -0.0427 0.2409 -0.9696 + 0.5010 -0.8345 -0.2294 + 4.0167 54.5377 12.4779) + #( 0.3706 -0.6167 0.6945 ; P-O3*-180-tfo + -0.2867 -0.7872 -0.5460 + 0.8834 0.0032 -0.4686 + -52.9020 18.6313 -0.6709) + #( 0.4155 0.9025 -0.1137 ; P-O3*-60-tfo + 0.9040 -0.4236 -0.0582 + -0.1007 -0.0786 -0.9918 + -7.6624 -25.2080 49.5181) + #( 31.3810 0.1400 47.5810) ; P + #( 29.9860 0.6630 47.6290) ; O1P + #( 31.7210 -0.6460 48.8090) ; O2P + #( 32.4940 1.2540 47.2740) ; O5* + #( 32.1610 2.2370 46.2560) ; C5* + #( 31.2986 2.8190 46.5812) ; H5* + #( 32.0980 1.7468 45.2845) ; H5** + #( 33.3476 3.1959 46.1947) ; C4* + #( 33.2668 3.8958 45.3630) ; H4* + #( 33.3799 3.9183 47.4216) ; O4* + #( 34.6515 3.7222 48.0398) ; C1* + #( 35.2947 4.5412 47.7180) ; H1* + #( 35.1756 2.4228 47.4827) ; C2* + #( 34.6778 1.5937 47.9856) ; H2** + #( 36.5631 2.2672 47.4798) ; O2* + #( 37.0163 2.6579 48.2305) ; H2* + #( 34.6953 2.5043 46.0448) ; C3* + #( 34.5444 1.4917 45.6706) ; H3* + #( 35.6679 3.3009 45.3487) ; O3* + #( 37.4804 4.0914 52.2559) ; N1 + #( 36.9670 4.1312 49.9281) ; N3 + #( 37.8045 4.2519 50.9550) ; C2 + #( 35.7171 3.8264 50.3222) ; C4 + #( 35.2668 3.6420 51.6115) ; C5 + #( 36.2037 3.7829 52.6706) ; C6 + #( 39.0869 4.5552 50.7092) ; N2 + #( 33.9075 3.3338 51.6102) ; N7 + #( 34.6126 3.6358 49.5108) ; N9 + #( 33.5805 3.3442 50.3425) ; C8 + #( 35.9958 3.6512 53.8724) ; O6 + #( 38.2106 4.2053 52.9295) ; H1 + #( 39.8218 4.6863 51.3896) ; H21 + #( 39.3420 4.6857 49.7407) ; H22 + #( 32.5194 3.1070 50.2664) ; H8 + )) + +(define rU* + (make-constant-rU + #( -0.0109 0.5907 0.8068 ; dgf-base-tfo + 0.2217 -0.7853 0.5780 + 0.9751 0.1852 -0.1224 + -1.4225 -11.0956 -2.5217) + #( -0.8313 -0.4738 -0.2906 ; P-O3*-275-tfo + 0.0649 0.4366 -0.8973 + 0.5521 -0.7648 -0.3322 + 1.6833 6.8060 -7.0011) + #( 0.3445 -0.7630 0.5470 ; P-O3*-180-tfo + -0.4628 -0.6450 -0.6082 + 0.8168 -0.0436 -0.5753 + -6.8179 -3.9778 -5.9887) + #( 0.5855 0.7931 -0.1682 ; P-O3*-60-tfo + 0.8103 -0.5790 0.0906 + -0.0255 -0.1894 -0.9816 + 6.1203 -7.1051 3.1984) + #( 2.6760 -8.4960 3.2880) ; P + #( 1.4950 -7.6230 3.4770) ; O1P + #( 2.9490 -9.4640 4.3740) ; O2P + #( 3.9730 -7.5950 3.0340) ; O5* + #( 5.2430 -8.2420 2.8260) ; C5* + #( 5.1974 -8.8497 1.9223) ; H5* + #( 5.5548 -8.7348 3.7469) ; H5** + #( 6.3140 -7.2060 2.5510) ; C4* + #( 5.8744 -6.2116 2.4731) ; H4* + #( 7.2798 -7.2260 3.6420) ; O4* + #( 8.5733 -6.9410 3.1329) ; C1* + #( 8.9047 -6.0374 3.6446) ; H1* + #( 8.4429 -6.6596 1.6327) ; C2* + #( 9.2880 -7.1071 1.1096) ; H2** + #( 8.2502 -5.2799 1.4754) ; O2* + #( 8.7676 -4.7284 2.0667) ; H2* + #( 7.1642 -7.4416 1.3021) ; C3* + #( 7.4125 -8.5002 1.2260) ; H3* + #( 6.5160 -6.9772 0.1267) ; O3* + #( 9.4531 -8.1107 3.4087) ; N1 + #( 11.5931 -9.0015 3.6357) ; N3 + #( 10.8101 -7.8950 3.3748) ; C2 + #( 11.1439 -10.2744 3.9206) ; C4 + #( 9.7056 -10.4026 3.9332) ; C5 + #( 8.9192 -9.3419 3.6833) ; C6 + #( 11.3013 -6.8063 3.1326) ; O2 + #( 11.9431 -11.1876 4.1375) ; O4 + #( 12.5840 -8.8673 3.6158) ; H3 + #( 9.2891 -11.2898 4.1313) ; H5 + #( 7.9263 -9.4537 3.6977) ; H6 + )) + + + +; -- PARTIAL INSTANTIATIONS --------------------------------------------------- + +(define (get-var id lst) + (let ((v (car lst))) + (if (= id (var-id v)) + v + (get-var id (cdr lst))))) + +(define (make-relative-nuc tfo n) + (cond ((rA? n) + (make-rA + (nuc-dgf-base-tfo n) + (nuc-P-O3*-275-tfo n) + (nuc-P-O3*-180-tfo n) + (nuc-P-O3*-60-tfo n) + (lazy-computation-of (tfo-apply tfo (nuc-P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O1P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5** n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2** n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-N1 n))) + (lazy-computation-of (tfo-apply tfo (nuc-N3 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C6 n))) + (lazy-computation-of (tfo-apply tfo (rA-N6 n))) + (lazy-computation-of (tfo-apply tfo (rA-N7 n))) + (lazy-computation-of (tfo-apply tfo (rA-N9 n))) + (lazy-computation-of (tfo-apply tfo (rA-C8 n))) + (lazy-computation-of (tfo-apply tfo (rA-H2 n))) + (lazy-computation-of (tfo-apply tfo (rA-H61 n))) + (lazy-computation-of (tfo-apply tfo (rA-H62 n))) + (lazy-computation-of (tfo-apply tfo (rA-H8 n))))) + ((rC? n) + (make-rC + (nuc-dgf-base-tfo n) + (nuc-P-O3*-275-tfo n) + (nuc-P-O3*-180-tfo n) + (nuc-P-O3*-60-tfo n) + (lazy-computation-of (tfo-apply tfo (nuc-P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O1P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5** n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2** n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-N1 n))) + (lazy-computation-of (tfo-apply tfo (nuc-N3 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C6 n))) + (lazy-computation-of (tfo-apply tfo (rC-N4 n))) + (lazy-computation-of (tfo-apply tfo (rC-O2 n))) + (lazy-computation-of (tfo-apply tfo (rC-H41 n))) + (lazy-computation-of (tfo-apply tfo (rC-H42 n))) + (lazy-computation-of (tfo-apply tfo (rC-H5 n))) + (lazy-computation-of (tfo-apply tfo (rC-H6 n))))) + ((rG? n) + (make-rG + (nuc-dgf-base-tfo n) + (nuc-P-O3*-275-tfo n) + (nuc-P-O3*-180-tfo n) + (nuc-P-O3*-60-tfo n) + (lazy-computation-of (tfo-apply tfo (nuc-P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O1P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5** n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2** n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-N1 n))) + (lazy-computation-of (tfo-apply tfo (nuc-N3 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C6 n))) + (lazy-computation-of (tfo-apply tfo (rG-N2 n))) + (lazy-computation-of (tfo-apply tfo (rG-N7 n))) + (lazy-computation-of (tfo-apply tfo (rG-N9 n))) + (lazy-computation-of (tfo-apply tfo (rG-C8 n))) + (lazy-computation-of (tfo-apply tfo (rG-O6 n))) + (lazy-computation-of (tfo-apply tfo (rG-H1 n))) + (lazy-computation-of (tfo-apply tfo (rG-H21 n))) + (lazy-computation-of (tfo-apply tfo (rG-H22 n))) + (lazy-computation-of (tfo-apply tfo (rG-H8 n))))) + (else + (make-rU + (nuc-dgf-base-tfo n) + (nuc-P-O3*-275-tfo n) + (nuc-P-O3*-180-tfo n) + (nuc-P-O3*-60-tfo n) + (lazy-computation-of (tfo-apply tfo (nuc-P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O1P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2P n))) + (lazy-computation-of (tfo-apply tfo (nuc-O5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H5** n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O4* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H1* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2** n))) + (lazy-computation-of (tfo-apply tfo (nuc-O2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H2* n))) + (lazy-computation-of (tfo-apply tfo (nuc-C3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-H3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-O3* n))) + (lazy-computation-of (tfo-apply tfo (nuc-N1 n))) + (lazy-computation-of (tfo-apply tfo (nuc-N3 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C2 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C4 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C5 n))) + (lazy-computation-of (tfo-apply tfo (nuc-C6 n))) + (lazy-computation-of (tfo-apply tfo (rU-O2 n))) + (lazy-computation-of (tfo-apply tfo (rU-O4 n))) + (lazy-computation-of (tfo-apply tfo (rU-H3 n))) + (lazy-computation-of (tfo-apply tfo (rU-H5 n))) + (lazy-computation-of (tfo-apply tfo (rU-H6 n))))))) + +; -- SEARCH ------------------------------------------------------------------- + +; Sequential backtracking algorithm + +(define (search partial-inst domains constraint?) + (if (null? domains) + (list partial-inst) + (let ((remaining-domains (cdr domains))) + + (define (try-assignments lst) + (if (null? lst) + '() + (let ((var (car lst))) + (if (constraint? var partial-inst) + (let* ((subsols1 + (search + (cons var partial-inst) + remaining-domains + constraint?)) + (subsols2 + (try-assignments (cdr lst)))) + (append subsols1 subsols2)) + (try-assignments (cdr lst)))))) + + (try-assignments ((car domains) partial-inst))))) + +; -- DOMAINS ------------------------------------------------------------------ + +; Primary structure: strand A CUGCCACGUCUG, strand B CAGACGUGGCAG +; +; Secondary structure: strand A CUGCCACGUCUG +; |||||||||||| +; GACGGUGCAGAC strand B +; +; Tertiary structure: +; +; 5' end of strand A C1----G12 3' end of strand B +; U2-------A11 +; G3-------C10 +; C4-----G9 +; C5---G8 +; A6 +; G6-C7 +; C5----G8 +; A4-------U9 +; G3--------C10 +; A2-------U11 +; 5' end of strand B C1----G12 3' end of strand A +; +; "helix", "stacked" and "connected" describe the spatial relationship +; between two consecutive nucleotides. E.g. the nucleotides C1 and U2 +; from the strand A. +; +; "wc" (stands for Watson-Crick and is a type of base-pairing), +; and "wc-dumas" describe the spatial relationship between +; nucleotides from two chains that are growing in opposite directions. +; E.g. the nucleotides C1 from strand A and G12 from strand B. + +; Dynamic Domains + +; Given, +; "ref" a nucleotide which is already positioned, +; "nuc" the nucleotide to be placed, +; and "tfo" a transformation matrix which expresses the desired +; relationship between "ref" and "nuc", +; the function "dgf-base" computes the transformation matrix that +; places the nucleotide "nuc" in the given relationship to "ref". + +(define (dgf-base tfo ref nuc) + (let* ((ref-nuc (var-nuc ref)) + (align + (tfo-inv-ortho + (cond ((rA? ref-nuc) + (tfo-align (atom-pos nuc-C1* ref) + (atom-pos rA-N9 ref) + (atom-pos nuc-C4 ref))) + ((rC? ref-nuc) + (tfo-align (atom-pos nuc-C1* ref) + (atom-pos nuc-N1 ref) + (atom-pos nuc-C2 ref))) + ((rG? ref-nuc) + (tfo-align (atom-pos nuc-C1* ref) + (atom-pos rG-N9 ref) + (atom-pos nuc-C4 ref))) + (else + (tfo-align (atom-pos nuc-C1* ref) + (atom-pos nuc-N1 ref) + (atom-pos nuc-C2 ref))))))) + (tfo-combine (nuc-dgf-base-tfo nuc) + (tfo-combine tfo align)))) + +; Placement of first nucleotide. + +(define (reference nuc i) + (lambda (partial-inst) + (list (mk-var i tfo-id nuc)))) + +; The transformation matrix for wc is from: +; +; Chandrasekaran R. et al (1989) A Re-Examination of the Crystal +; Structure of A-DNA Using Fiber Diffraction Data. J. Biomol. +; Struct. & Dynamics 6(6):1189-1202. + +(define wc-tfo + '#(-1.0000 0.0028 -0.0019 + 0.0028 0.3468 -0.9379 + -0.0019 -0.9379 -0.3468 + -0.0080 6.0730 8.7208)) + +(define (wc nuc i j) + (lambda (partial-inst) + (let* ((ref (get-var j partial-inst)) + (tfo (dgf-base wc-tfo ref nuc))) + (list (mk-var i tfo nuc))))) + +(define wc-Dumas-tfo + '#(-0.9737 -0.1834 0.1352 + -0.1779 0.2417 -0.9539 + 0.1422 -0.9529 -0.2679 + 0.4837 6.2649 8.0285)) + +(define (wc-Dumas nuc i j) + (lambda (partial-inst) + (let* ((ref (get-var j partial-inst)) + (tfo (dgf-base wc-Dumas-tfo ref nuc))) + (list (mk-var i tfo nuc))))) + +(define helix5*-tfo + '#( 0.9886 -0.0961 0.1156 + 0.1424 0.8452 -0.5152 + -0.0482 0.5258 0.8492 + -3.8737 0.5480 3.8024)) + +(define (helix5* nuc i j) + (lambda (partial-inst) + (let* ((ref (get-var j partial-inst)) + (tfo (dgf-base helix5*-tfo ref nuc))) + (list (mk-var i tfo nuc))))) + +(define helix3*-tfo + '#( 0.9886 0.1424 -0.0482 + -0.0961 0.8452 0.5258 + 0.1156 -0.5152 0.8492 + 3.4426 2.0474 -3.7042)) + +(define (helix3* nuc i j) + (lambda (partial-inst) + (let* ((ref (get-var j partial-inst)) + (tfo (dgf-base helix3*-tfo ref nuc))) + (list (mk-var i tfo nuc))))) + +(define G37-A38-tfo + '#( 0.9991 0.0164 -0.0387 + -0.0375 0.7616 -0.6470 + 0.0189 0.6478 0.7615 + -3.3018 0.9975 2.5585)) + +(define (G37-A38 nuc i j) + (lambda (partial-inst) + (let* ((ref (get-var j partial-inst)) + (tfo (dgf-base G37-A38-tfo ref nuc))) + (mk-var i tfo nuc)))) + +(define (stacked5* nuc i j) + (lambda (partial-inst) + (cons ((G37-A38 nuc i j) partial-inst) + ((helix5* nuc i j) partial-inst)))) + +(define A38-G37-tfo + '#( 0.9991 -0.0375 0.0189 + 0.0164 0.7616 0.6478 + -0.0387 -0.6470 0.7615 + 3.3819 0.7718 -2.5321)) + +(define (A38-G37 nuc i j) + (lambda (partial-inst) + (let* ((ref (get-var j partial-inst)) + (tfo (dgf-base A38-G37-tfo ref nuc))) + (mk-var i tfo nuc)))) + +(define (stacked3* nuc i j) + (lambda (partial-inst) + (cons ((A38-G37 nuc i j) partial-inst) + ((helix3* nuc i j) partial-inst)))) + +(define (P-O3* nucs i j) + (lambda (partial-inst) + (let* ((ref (get-var j partial-inst)) + (align + (tfo-inv-ortho + (tfo-align (atom-pos nuc-O3* ref) + (atom-pos nuc-C3* ref) + (atom-pos nuc-C4* ref))))) + (let loop ((lst nucs) (domains '())) + (if (null? lst) + domains + (let ((nuc (car lst))) + (let ((tfo-60 (tfo-combine (nuc-P-O3*-60-tfo nuc) align)) + (tfo-180 (tfo-combine (nuc-P-O3*-180-tfo nuc) align)) + (tfo-275 (tfo-combine (nuc-P-O3*-275-tfo nuc) align))) + (loop (cdr lst) + (cons (mk-var i tfo-60 nuc) + (cons (mk-var i tfo-180 nuc) + (cons (mk-var i tfo-275 nuc) domains))))))))))) + +; -- PROBLEM STATEMENT -------------------------------------------------------- + +; Define anticodon problem -- Science 253:1255 Figure 3a, 3b and 3c + +(define anticodon-domains + (list + (reference rC 27 ) + (helix5* rC 28 27) + (helix5* rA 29 28) + (helix5* rG 30 29) + (helix5* rA 31 30) + (wc rU 39 31) + (helix5* rC 40 39) + (helix5* rU 41 40) + (helix5* rG 42 41) + (helix5* rG 43 42) + (stacked3* rA 38 39) + (stacked3* rG 37 38) + (stacked3* rA 36 37) + (stacked3* rA 35 36) + (stacked3* rG 34 35);<-. Distance + (P-O3* rCs 32 31); | Constraint + (P-O3* rUs 33 32);<-' 3.0 Angstroms + )) + +; Anticodon constraint + +(define (anticodon-constraint? v partial-inst) + (if (= (var-id v) 33) + (let ((p (atom-pos nuc-P (get-var 34 partial-inst))) ; P in nucleotide 34 + (o3* (atom-pos nuc-O3* v))) ; O3' in nucl. 33 + (FLOAT<= (pt-dist p o3*) 3.0)) ; check distance + #t)) + +(define (anticodon) + (search '() anticodon-domains anticodon-constraint?)) + +; Define pseudoknot problem -- Science 253:1255 Figure 4a and 4b + +(define pseudoknot-domains + (list + (reference rA 23 ) + (wc-Dumas rU 8 23) + (helix3* rG 22 23) + (wc-Dumas rC 9 22) + (helix3* rG 21 22) + (wc-Dumas rC 10 21) + (helix3* rC 20 21) + (wc-Dumas rG 11 20) + (helix3* rU* 19 20);<-. + (wc-Dumas rA 12 19); | Distance +; ; | Constraint +; Helix 1 ; | 4.0 Angstroms + (helix3* rC 3 19); | + (wc-Dumas rG 13 3); | + (helix3* rC 2 3); | + (wc-Dumas rG 14 2); | + (helix3* rC 1 2); | + (wc-Dumas rG* 15 1); | +; ; | +; L2 LOOP ; | + (P-O3* rUs 16 15); | + (P-O3* rCs 17 16); | + (P-O3* rAs 18 17);<-' +; +; L1 LOOP + (helix3* rU 7 8);<-. + (P-O3* rCs 4 3); | Constraint + (stacked5* rU 5 4); | 4.5 Angstroms + (stacked5* rC 6 5);<-' + )) + +; Pseudoknot constraint + +(define (pseudoknot-constraint? v partial-inst) + (case (var-id v) + ((18) + (let ((p (atom-pos nuc-P (get-var 19 partial-inst))) + (o3* (atom-pos nuc-O3* v))) + (FLOAT<= (pt-dist p o3*) 4.0))) + ((6) + (let ((p (atom-pos nuc-P (get-var 7 partial-inst))) + (o3* (atom-pos nuc-O3* v))) + (FLOAT<= (pt-dist p o3*) 4.5))) + (else + #t))) + +(define (pseudoknot) + (search '() pseudoknot-domains pseudoknot-constraint?)) + +; -- TESTING ----------------------------------------------------------------- + +(define (list-of-atoms n) + (append (list-of-common-atoms n) + (list-of-specific-atoms n))) + +(define (list-of-common-atoms n) + (list + (nuc-P n) + (nuc-O1P n) + (nuc-O2P n) + (nuc-O5* n) + (nuc-C5* n) + (nuc-H5* n) + (nuc-H5** n) + (nuc-C4* n) + (nuc-H4* n) + (nuc-O4* n) + (nuc-C1* n) + (nuc-H1* n) + (nuc-C2* n) + (nuc-H2** n) + (nuc-O2* n) + (nuc-H2* n) + (nuc-C3* n) + (nuc-H3* n) + (nuc-O3* n) + (nuc-N1 n) + (nuc-N3 n) + (nuc-C2 n) + (nuc-C4 n) + (nuc-C5 n) + (nuc-C6 n))) + +(define (list-of-specific-atoms n) + (cond ((rA? n) + (list + (rA-N6 n) + (rA-N7 n) + (rA-N9 n) + (rA-C8 n) + (rA-H2 n) + (rA-H61 n) + (rA-H62 n) + (rA-H8 n))) + ((rC? n) + (list + (rC-N4 n) + (rC-O2 n) + (rC-H41 n) + (rC-H42 n) + (rC-H5 n) + (rC-H6 n))) + ((rG? n) + (list + (rG-N2 n) + (rG-N7 n) + (rG-N9 n) + (rG-C8 n) + (rG-O6 n) + (rG-H1 n) + (rG-H21 n) + (rG-H22 n) + (rG-H8 n))) + (else + (list + (rU-O2 n) + (rU-O4 n) + (rU-H3 n) + (rU-H5 n) + (rU-H6 n))))) + +(define (var-most-distant-atom v) + + (define (distance pos) + (let ((abs-pos (absolute-pos v pos))) + (let ((x (pt-x abs-pos)) (y (pt-y abs-pos)) (z (pt-z abs-pos))) + (FLOATsqrt (FLOAT+ (FLOAT* x x) (FLOAT* y y) (FLOAT* z z)))))) + + (maximum (map distance (list-of-atoms (var-nuc v))))) + +(define (sol-most-distant-atom s) + (maximum (map var-most-distant-atom s))) + +(define (most-distant-atom sols) + (maximum (map sol-most-distant-atom sols))) + +(define (maximum lst) + (let loop ((m (car lst)) (l (cdr lst))) + (if (null? l) + m + (let ((x (car l))) + (loop (if (FLOAT> x m) x m) (cdr l)))))) + +(define (check) + (length (pseudoknot))) + +(define (run) + (most-distant-atom (pseudoknot))) + +; To run program, evaluate: (run) + +(time (let loop ((i 10)) (if (zero? i) 'done (begin (run) (loop (- i 1)))))) diff --git a/benchmarks/gabriel/paraffins.sch b/benchmarks/gabriel/paraffins.sch new file mode 100644 index 00000000..708a85ad --- /dev/null +++ b/benchmarks/gabriel/paraffins.sch @@ -0,0 +1,175 @@ +;;; PARAFFINS -- Compute how many paraffins exist with N carbon atoms. + +(define (gen n) + (let* ((n/2 (quotient n 2)) + (radicals (make-vector (+ n/2 1) '(H)))) + + (define (rads-of-size n) + (let loop1 ((ps + (three-partitions (- n 1))) + (lst + '())) + (if (null? ps) + lst + (let* ((p (car ps)) + (nc1 (vector-ref p 0)) + (nc2 (vector-ref p 1)) + (nc3 (vector-ref p 2))) + (let loop2 ((rads1 + (vector-ref radicals nc1)) + (lst + (loop1 (cdr ps) + lst))) + (if (null? rads1) + lst + (let loop3 ((rads2 + (if (= nc1 nc2) + rads1 + (vector-ref radicals nc2))) + (lst + (loop2 (cdr rads1) + lst))) + (if (null? rads2) + lst + (let loop4 ((rads3 + (if (= nc2 nc3) + rads2 + (vector-ref radicals nc3))) + (lst + (loop3 (cdr rads2) + lst))) + (if (null? rads3) + lst + (cons (vector 'C + (car rads1) + (car rads2) + (car rads3)) + (loop4 (cdr rads3) + lst)))))))))))) + + (define (bcp-generator j) + (if (odd? j) + '() + (let loop1 ((rads1 + (vector-ref radicals (quotient j 2))) + (lst + '())) + (if (null? rads1) + lst + (let loop2 ((rads2 + rads1) + (lst + (loop1 (cdr rads1) + lst))) + (if (null? rads2) + lst + (cons (vector 'BCP + (car rads1) + (car rads2)) + (loop2 (cdr rads2) + lst)))))))) + + (define (ccp-generator j) + (let loop1 ((ps + (four-partitions (- j 1))) + (lst + '())) + (if (null? ps) + lst + (let* ((p (car ps)) + (nc1 (vector-ref p 0)) + (nc2 (vector-ref p 1)) + (nc3 (vector-ref p 2)) + (nc4 (vector-ref p 3))) + (let loop2 ((rads1 + (vector-ref radicals nc1)) + (lst + (loop1 (cdr ps) + lst))) + (if (null? rads1) + lst + (let loop3 ((rads2 + (if (= nc1 nc2) + rads1 + (vector-ref radicals nc2))) + (lst + (loop2 (cdr rads1) + lst))) + (if (null? rads2) + lst + (let loop4 ((rads3 + (if (= nc2 nc3) + rads2 + (vector-ref radicals nc3))) + (lst + (loop3 (cdr rads2) + lst))) + (if (null? rads3) + lst + (let loop5 ((rads4 + (if (= nc3 nc4) + rads3 + (vector-ref radicals nc4))) + (lst + (loop4 (cdr rads3) + lst))) + (if (null? rads4) + lst + (cons (vector 'CCP + (car rads1) + (car rads2) + (car rads3) + (car rads4)) + (loop5 (cdr rads4) + lst)))))))))))))) + + (let loop ((i 1)) + (if (> i n/2) + (vector (bcp-generator n) + (ccp-generator n)) + (begin + (vector-set! radicals i (rads-of-size i)) + (loop (+ i 1))))))) + +(define (three-partitions m) + (let loop1 ((lst '()) + (nc1 (quotient m 3))) + (if (< nc1 0) + lst + (let loop2 ((lst lst) + (nc2 (quotient (- m nc1) 2))) + (if (< nc2 nc1) + (loop1 lst + (- nc1 1)) + (loop2 (cons (vector nc1 nc2 (- m (+ nc1 nc2))) lst) + (- nc2 1))))))) + +(define (four-partitions m) + (let loop1 ((lst '()) + (nc1 (quotient m 4))) + (if (< nc1 0) + lst + (let loop2 ((lst lst) + (nc2 (quotient (- m nc1) 3))) + (if (< nc2 nc1) + (loop1 lst + (- nc1 1)) + (let ((start (max nc2 (- (quotient (+ m 1) 2) (+ nc1 nc2))))) + (let loop3 ((lst lst) + (nc3 (quotient (- m (+ nc1 nc2)) 2))) + (if (< nc3 start) + (loop2 lst (- nc2 1)) + (loop3 (cons (vector nc1 nc2 nc3 (- m (+ nc1 (+ nc2 nc3)))) lst) + (- nc3 1)))))))))) + +(define (nb n) + (let ((x (gen n))) + (+ (length (vector-ref x 0)) + (length (vector-ref x 1))))) + +(let ((input (with-input-from-file "input.txt" read))) + (time + (let loop ((n 100) (v 0)) + (if (zero? n) + v + (loop (- n 1) (nb (if input 17 0))))))) diff --git a/benchmarks/gabriel/peval.sch b/benchmarks/gabriel/peval.sch new file mode 100644 index 00000000..40d50471 --- /dev/null +++ b/benchmarks/gabriel/peval.sch @@ -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))))))) diff --git a/benchmarks/gabriel/puzzle.sch b/benchmarks/gabriel/puzzle.sch new file mode 100644 index 00000000..69cb0690 --- /dev/null +++ b/benchmarks/gabriel/puzzle.sch @@ -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)) + + diff --git a/benchmarks/gabriel/run.sh b/benchmarks/gabriel/run.sh new file mode 100755 index 00000000..36dba94f --- /dev/null +++ b/benchmarks/gabriel/run.sh @@ -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 - diff --git a/benchmarks/gabriel/sboyer.sch b/benchmarks/gabriel/sboyer.sch new file mode 100644 index 00000000..37befe9d --- /dev/null +++ b/benchmarks/gabriel/sboyer.sch @@ -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) diff --git a/benchmarks/gabriel/scheme.sch b/benchmarks/gabriel/scheme.sch new file mode 100644 index 00000000..ac891d53 --- /dev/null +++ b/benchmarks/gabriel/scheme.sch @@ -0,0 +1,1077 @@ +;;; SCHEME -- A Scheme interpreter evaluating a sort, written by Marc Feeley. + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-eval expr) + (let ((code (scheme-comp expr scheme-global-environment))) + (code #f))) + +(define scheme-global-environment + (cons '() ; environment chain + '())) ; macros + +(define (scheme-add-macro name proc) + (set-cdr! scheme-global-environment + (cons (cons name proc) (cdr scheme-global-environment))) + name) + +(define (scheme-error msg . args) + 'error) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (lst->vector l) + (let* ((n (length l)) + (v (make-vector n))) + (let loop ((l l) (i 0)) + (if (pair? l) + (begin + (vector-set! v i (car l)) + (loop (cdr l) (+ i 1))) + v)))) + +(define (vector->lst v) + (let loop ((l '()) (i (- (vector-length v) 1))) + (if (< i 0) + l + (loop (cons (vector-ref v i) l) (- i 1))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define scheme-syntactic-keywords + '(quote quasiquote unquote unquote-splicing + lambda if set! cond => else and or + case let let* letrec begin do define + define-macro)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (push-frame frame env) + (if (null? frame) + env + (cons (cons (car env) frame) (cdr env)))) + +(define (lookup-var name env) + (let loop1 ((chain (car env)) (up 0)) + (if (null? chain) + name + (let loop2 ((chain chain) + (up up) + (frame (cdr chain)) + (over 1)) + (cond ((null? frame) + (loop1 (car chain) (+ up 1))) + ((eq? (car frame) name) + (cons up over)) + (else + (loop2 chain up (cdr frame) (+ over 1)))))))) + +(define (macro? name env) + (assq name (cdr env))) + +(define (push-macro name proc env) + (cons (car env) (cons (cons name proc) (cdr env)))) + +(define (lookup-macro name env) + (cdr (assq name (cdr env)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (variable x) + (if (not (symbol? x)) + (scheme-error "Identifier expected" x)) + (if (memq x scheme-syntactic-keywords) + (scheme-error "Variable name can not be a syntactic keyword" x))) + +(define (shape form n) + (let loop ((form form) (n n) (l form)) + (cond ((<= n 0)) + ((pair? l) + (loop form (- n 1) (cdr l))) + (else + (scheme-error "Ill-constructed form" form))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (macro-expand expr env) + (apply (lookup-macro (car expr) env) (cdr expr))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-var expr env) + (variable expr) + (gen-var-ref (lookup-var expr env))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-self-eval expr env) + (gen-cst expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-quote expr env) + (shape expr 2) + (gen-cst (cadr expr))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-quasiquote expr env) + (comp-quasiquotation (cadr expr) 1 env)) + +(define (comp-quasiquotation form level env) + (cond ((= level 0) + (scheme-comp form env)) + ((pair? form) + (cond + ((eq? (car form) 'quasiquote) + (comp-quasiquotation-list form (+ level 1) env)) + ((eq? (car form) 'unquote) + (if (= level 1) + (scheme-comp (cadr form) env) + (comp-quasiquotation-list form (- level 1) env))) + ((eq? (car form) 'unquote-splicing) + (if (= level 1) + (scheme-error "Ill-placed 'unquote-splicing'" form)) + (comp-quasiquotation-list form (- level 1) env)) + (else + (comp-quasiquotation-list form level env)))) + ((vector? form) + (gen-vector-form + (comp-quasiquotation-list (vector->lst form) level env))) + (else + (gen-cst form)))) + +(define (comp-quasiquotation-list l level env) + (if (pair? l) + (let ((first (car l))) + (if (= level 1) + (if (unquote-splicing? first) + (begin + (shape first 2) + (gen-append-form (scheme-comp (cadr first) env) + (comp-quasiquotation (cdr l) 1 env))) + (gen-cons-form (comp-quasiquotation first level env) + (comp-quasiquotation (cdr l) level env))) + (gen-cons-form (comp-quasiquotation first level env) + (comp-quasiquotation (cdr l) level env)))) + (comp-quasiquotation l level env))) + +(define (unquote-splicing? x) + (if (pair? x) + (if (eq? (car x) 'unquote-splicing) #t #f) + #f)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-unquote expr env) + (scheme-error "Ill-placed 'unquote'" expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-unquote-splicing expr env) + (scheme-error "Ill-placed 'unquote-splicing'" expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-set! expr env) + (shape expr 3) + (variable (cadr expr)) + (gen-var-set (lookup-var (cadr expr) env) (scheme-comp (caddr expr) env))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-lambda expr env) + (shape expr 3) + (let ((parms (cadr expr))) + (let ((frame (parms->frame parms))) + (let ((nb-vars (length frame)) + (code (comp-body (cddr expr) (push-frame frame env)))) + (if (rest-param? parms) + (gen-lambda-rest nb-vars code) + (gen-lambda nb-vars code)))))) + +(define (parms->frame parms) + (cond ((null? parms) + '()) + ((pair? parms) + (let ((x (car parms))) + (variable x) + (cons x (parms->frame (cdr parms))))) + (else + (variable parms) + (list parms)))) + +(define (rest-param? parms) + (cond ((pair? parms) + (rest-param? (cdr parms))) + ((null? parms) + #f) + (else + #t))) + +(define (comp-body body env) + + (define (letrec-defines vars vals body env) + (if (pair? body) + + (let ((expr (car body))) + (cond ((not (pair? expr)) + (letrec-defines* vars vals body env)) + ((macro? (car expr) env) + (letrec-defines vars + vals + (cons (macro-expand expr env) (cdr body)) + env)) + (else + (cond + ((eq? (car expr) 'begin) + (letrec-defines vars + vals + (append (cdr expr) (cdr body)) + env)) + ((eq? (car expr) 'define) + (let ((x (definition-name expr))) + (variable x) + (letrec-defines (cons x vars) + (cons (definition-value expr) vals) + (cdr body) + env))) + ((eq? (car expr) 'define-macro) + (let ((x (definition-name expr))) + (letrec-defines vars + vals + (cdr body) + (push-macro + x + (scheme-eval (definition-value expr)) + env)))) + (else + (letrec-defines* vars vals body env)))))) + + (scheme-error "Body must contain at least one evaluable expression"))) + + (define (letrec-defines* vars vals body env) + (if (null? vars) + (comp-sequence body env) + (comp-letrec-aux vars vals body env))) + + (letrec-defines '() '() body env)) + +(define (definition-name expr) + (shape expr 3) + (let ((pattern (cadr expr))) + (let ((name (if (pair? pattern) (car pattern) pattern))) + (if (not (symbol? name)) + (scheme-error "Identifier expected" name)) + name))) + +(define (definition-value expr) + (let ((pattern (cadr expr))) + (if (pair? pattern) + (cons 'lambda (cons (cdr pattern) (cddr expr))) + (caddr expr)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-if expr env) + (shape expr 3) + (let ((code1 (scheme-comp (cadr expr) env)) + (code2 (scheme-comp (caddr expr) env))) + (if (pair? (cdddr expr)) + (gen-if code1 code2 (scheme-comp (cadddr expr) env)) + (gen-when code1 code2)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-cond expr env) + (comp-cond-aux (cdr expr) env)) + +(define (comp-cond-aux clauses env) + (if (pair? clauses) + (let ((clause (car clauses))) + (shape clause 1) + (cond ((eq? (car clause) 'else) + (shape clause 2) + (comp-sequence (cdr clause) env)) + ((not (pair? (cdr clause))) + (gen-or (scheme-comp (car clause) env) + (comp-cond-aux (cdr clauses) env))) + ((eq? (cadr clause) '=>) + (shape clause 3) + (gen-cond-send (scheme-comp (car clause) env) + (scheme-comp (caddr clause) env) + (comp-cond-aux (cdr clauses) env))) + (else + (gen-if (scheme-comp (car clause) env) + (comp-sequence (cdr clause) env) + (comp-cond-aux (cdr clauses) env))))) + (gen-cst '()))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-and expr env) + (let ((rest (cdr expr))) + (if (pair? rest) (comp-and-aux rest env) (gen-cst #t)))) + +(define (comp-and-aux l env) + (let ((code (scheme-comp (car l) env)) + (rest (cdr l))) + (if (pair? rest) (gen-and code (comp-and-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-or expr env) + (let ((rest (cdr expr))) + (if (pair? rest) (comp-or-aux rest env) (gen-cst #f)))) + +(define (comp-or-aux l env) + (let ((code (scheme-comp (car l) env)) + (rest (cdr l))) + (if (pair? rest) (gen-or code (comp-or-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-case expr env) + (shape expr 3) + (gen-case (scheme-comp (cadr expr) env) + (comp-case-aux (cddr expr) env))) + +(define (comp-case-aux clauses env) + (if (pair? clauses) + (let ((clause (car clauses))) + (shape clause 2) + (if (eq? (car clause) 'else) + (gen-case-else (comp-sequence (cdr clause) env)) + (gen-case-clause (car clause) + (comp-sequence (cdr clause) env) + (comp-case-aux (cdr clauses) env)))) + (gen-case-else (gen-cst '())))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-let expr env) + (shape expr 3) + (let ((x (cadr expr))) + (cond ((symbol? x) + (shape expr 4) + (let ((y (caddr expr))) + (let ((proc (cons 'lambda (cons (bindings->vars y) (cdddr expr))))) + (scheme-comp (cons (list 'letrec (list (list x proc)) x) + (bindings->vals y)) + env)))) + ((pair? x) + (scheme-comp (cons (cons 'lambda (cons (bindings->vars x) (cddr expr))) + (bindings->vals x)) + env)) + (else + (comp-body (cddr expr) env))))) + +(define (bindings->vars bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (shape binding 2) + (let ((x (car binding))) + (variable x) + (cons x (bindings->vars (cdr bindings))))) + '())) + +(define (bindings->vals bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (cons (cadr binding) (bindings->vals (cdr bindings)))) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-let* expr env) + (shape expr 3) + (let ((bindings (cadr expr))) + (if (pair? bindings) + (scheme-comp (list 'let + (list (car bindings)) + (cons 'let* (cons (cdr bindings) (cddr expr)))) + env) + (comp-body (cddr expr) env)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-letrec expr env) + (shape expr 3) + (let ((bindings (cadr expr))) + (comp-letrec-aux (bindings->vars bindings) + (bindings->vals bindings) + (cddr expr) + env))) + +(define (comp-letrec-aux vars vals body env) + (if (pair? vars) + (let ((new-env (push-frame vars env))) + (gen-letrec (comp-vals vals new-env) + (comp-body body new-env))) + (comp-body body env))) + +(define (comp-vals l env) + (if (pair? l) + (cons (scheme-comp (car l) env) (comp-vals (cdr l) env)) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-begin expr env) + (shape expr 2) + (comp-sequence (cdr expr) env)) + +(define (comp-sequence exprs env) + (if (pair? exprs) + (comp-sequence-aux exprs env) + (gen-cst '()))) + +(define (comp-sequence-aux exprs env) + (let ((code (scheme-comp (car exprs) env)) + (rest (cdr exprs))) + (if (pair? rest) (gen-sequence code (comp-sequence-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-do expr env) + (shape expr 3) + (let ((bindings (cadr expr)) + (exit (caddr expr))) + (shape exit 1) + (let* ((vars (bindings->vars bindings)) + (new-env1 (push-frame '(#f) env)) + (new-env2 (push-frame vars new-env1))) + (gen-letrec + (list + (gen-lambda + (length vars) + (gen-if + (scheme-comp (car exit) new-env2) + (comp-sequence (cdr exit) new-env2) + (gen-sequence + (comp-sequence (cdddr expr) new-env2) + (gen-combination + (gen-var-ref '(1 . 1)) + (comp-vals (bindings->steps bindings) new-env2)))))) + (gen-combination + (gen-var-ref '(0 . 1)) + (comp-vals (bindings->vals bindings) new-env1)))))) + +(define (bindings->steps bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (cons (if (pair? (cddr binding)) (caddr binding) (car binding)) + (bindings->steps (cdr bindings)))) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-define expr env) + (shape expr 3) + (let ((pattern (cadr expr))) + (let ((x (if (pair? pattern) (car pattern) pattern))) + (variable x) + (gen-sequence + (gen-var-set (lookup-var x env) + (scheme-comp (if (pair? pattern) + (cons 'lambda (cons (cdr pattern) (cddr expr))) + (caddr expr)) + env)) + (gen-cst x))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-define-macro expr env) + (let ((x (definition-name expr))) + (gen-macro x (scheme-eval (definition-value expr))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-combination expr env) + (gen-combination (scheme-comp (car expr) env) (comp-vals (cdr expr) env))) + +;------------------------------------------------------------------------------ + +(define (gen-var-ref var) + (if (pair? var) + (gen-rte-ref (car var) (cdr var)) + (gen-glo-ref (scheme-global-var var)))) + +(define (gen-rte-ref up over) + (case up + ((0) (gen-slot-ref-0 over)) + ((1) (gen-slot-ref-1 over)) + (else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over))))) + +(define (gen-slot-ref-0 i) + (case i + ((0) (lambda (rte) (vector-ref rte 0))) + ((1) (lambda (rte) (vector-ref rte 1))) + ((2) (lambda (rte) (vector-ref rte 2))) + ((3) (lambda (rte) (vector-ref rte 3))) + (else (lambda (rte) (vector-ref rte i))))) + +(define (gen-slot-ref-1 i) + (case i + ((0) (lambda (rte) (vector-ref (vector-ref rte 0) 0))) + ((1) (lambda (rte) (vector-ref (vector-ref rte 0) 1))) + ((2) (lambda (rte) (vector-ref (vector-ref rte 0) 2))) + ((3) (lambda (rte) (vector-ref (vector-ref rte 0) 3))) + (else (lambda (rte) (vector-ref (vector-ref rte 0) i))))) + +(define (gen-slot-ref-up-2 code) + (lambda (rte) (code (vector-ref (vector-ref rte 0) 0)))) + +(define (gen-glo-ref i) + (lambda (rte) (scheme-global-var-ref i))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-cst val) + (case val + ((()) (lambda (rte) '())) + ((#f) (lambda (rte) #f)) + ((#t) (lambda (rte) #t)) + ((-2) (lambda (rte) -2)) + ((-1) (lambda (rte) -1)) + ((0) (lambda (rte) 0)) + ((1) (lambda (rte) 1)) + ((2) (lambda (rte) 2)) + (else (lambda (rte) val)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-append-form code1 code2) + (lambda (rte) (append (code1 rte) (code2 rte)))) + +(define (gen-cons-form code1 code2) + (lambda (rte) (cons (code1 rte) (code2 rte)))) + +(define (gen-vector-form code) + (lambda (rte) (lst->vector (code rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-var-set var code) + (if (pair? var) + (gen-rte-set (car var) (cdr var) code) + (gen-glo-set (scheme-global-var var) code))) + +(define (gen-rte-set up over code) + (case up + ((0) (gen-slot-set-0 over code)) + ((1) (gen-slot-set-1 over code)) + (else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code)))) + +(define (gen-slot-set-0 i code) + (case i + ((0) (lambda (rte) (vector-set! rte 0 (code rte)))) + ((1) (lambda (rte) (vector-set! rte 1 (code rte)))) + ((2) (lambda (rte) (vector-set! rte 2 (code rte)))) + ((3) (lambda (rte) (vector-set! rte 3 (code rte)))) + (else (lambda (rte) (vector-set! rte i (code rte)))))) + +(define (gen-slot-set-1 i code) + (case i + ((0) (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte)))) + ((1) (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte)))) + ((2) (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte)))) + ((3) (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte)))) + (else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte)))))) + +(define (gen-slot-set-n up i code) + (case i + ((0) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte)))) + ((1) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte)))) + ((2) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte)))) + ((3) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte)))) + (else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte)))))) + +(define (gen-glo-set i code) + (lambda (rte) (scheme-global-var-set! i (code rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-lambda-rest nb-vars body) + (case nb-vars + ((1) (gen-lambda-1-rest body)) + ((2) (gen-lambda-2-rest body)) + ((3) (gen-lambda-3-rest body)) + (else (gen-lambda-n-rest nb-vars body)))) + +(define (gen-lambda-1-rest body) + (lambda (rte) + (lambda a + (body (vector rte a))))) + +(define (gen-lambda-2-rest body) + (lambda (rte) + (lambda (a . b) + (body (vector rte a b))))) + +(define (gen-lambda-3-rest body) + (lambda (rte) + (lambda (a b . c) + (body (vector rte a b c))))) + +(define (gen-lambda-n-rest nb-vars body) + (lambda (rte) + (lambda (a b c . d) + (let ((x (make-vector (+ nb-vars 1)))) + (vector-set! x 0 rte) + (vector-set! x 1 a) + (vector-set! x 2 b) + (vector-set! x 3 c) + (let loop ((n nb-vars) (x x) (i 4) (l d)) + (if (< i n) + (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))) + (vector-set! x i l))) + (body x))))) + +(define (gen-lambda nb-vars body) + (case nb-vars + ((0) (gen-lambda-0 body)) + ((1) (gen-lambda-1 body)) + ((2) (gen-lambda-2 body)) + ((3) (gen-lambda-3 body)) + (else (gen-lambda-n nb-vars body)))) + +(define (gen-lambda-0 body) + (lambda (rte) + (lambda () + (body rte)))) + +(define (gen-lambda-1 body) + (lambda (rte) + (lambda (a) + (body (vector rte a))))) + +(define (gen-lambda-2 body) + (lambda (rte) + (lambda (a b) + (body (vector rte a b))))) + +(define (gen-lambda-3 body) + (lambda (rte) + (lambda (a b c) + (body (vector rte a b c))))) + +(define (gen-lambda-n nb-vars body) + (lambda (rte) + (lambda (a b c . d) + (let ((x (make-vector (+ nb-vars 1)))) + (vector-set! x 0 rte) + (vector-set! x 1 a) + (vector-set! x 2 b) + (vector-set! x 3 c) + (let loop ((n nb-vars) (x x) (i 4) (l d)) + (if (<= i n) + (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))))) + (body x))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-sequence code1 code2) + (lambda (rte) (code1 rte) (code2 rte))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-when code1 code2) + (lambda (rte) + (if (code1 rte) + (code2 rte) + '()))) + +(define (gen-if code1 code2 code3) + (lambda (rte) + (if (code1 rte) + (code2 rte) + (code3 rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-cond-send code1 code2 code3) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + ((code2 rte) temp) + (code3 rte))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-and code1 code2) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + (code2 rte) + temp)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-or code1 code2) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + temp + (code2 rte))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-case code1 code2) + (lambda (rte) (code2 rte (code1 rte)))) + +(define (gen-case-clause datums code1 code2) + (lambda (rte key) (if (memv key datums) (code1 rte) (code2 rte key)))) + +(define (gen-case-else code) + (lambda (rte key) (code rte))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-letrec vals body) + (let ((nb-vals (length vals))) + (case nb-vals + ((1) (gen-letrec-1 (car vals) body)) + ((2) (gen-letrec-2 (car vals) (cadr vals) body)) + ((3) (gen-letrec-3 (car vals) (cadr vals) (caddr vals) body)) + (else (gen-letrec-n nb-vals vals body))))) + +(define (gen-letrec-1 val1 body) + (lambda (rte) + (let ((x (vector rte #f))) + (vector-set! x 1 (val1 x)) + (body x)))) + +(define (gen-letrec-2 val1 val2 body) + (lambda (rte) + (let ((x (vector rte #f #f))) + (vector-set! x 1 (val1 x)) + (vector-set! x 2 (val2 x)) + (body x)))) + +(define (gen-letrec-3 val1 val2 val3 body) + (lambda (rte) + (let ((x (vector rte #f #f #f))) + (vector-set! x 1 (val1 x)) + (vector-set! x 2 (val2 x)) + (vector-set! x 3 (val3 x)) + (body x)))) + +(define (gen-letrec-n nb-vals vals body) + (lambda (rte) + (let ((x (make-vector (+ nb-vals 1)))) + (vector-set! x 0 rte) + (let loop ((x x) (i 1) (l vals)) + (if (pair? l) + (begin (vector-set! x i ((car l) x)) (loop x (+ i 1) (cdr l))))) + (body x)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-macro name proc) + (lambda (rte) (scheme-add-macro name proc))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-combination oper args) + (case (length args) + ((0) (gen-combination-0 oper)) + ((1) (gen-combination-1 oper (car args))) + ((2) (gen-combination-2 oper (car args) (cadr args))) + ((3) (gen-combination-3 oper (car args) (cadr args) (caddr args))) + (else (gen-combination-n oper args)))) + +(define (gen-combination-0 oper) + (lambda (rte) ((oper rte)))) + +(define (gen-combination-1 oper arg1) + (lambda (rte) ((oper rte) (arg1 rte)))) + +(define (gen-combination-2 oper arg1 arg2) + (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte)))) + +(define (gen-combination-3 oper arg1 arg2 arg3) + (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte) (arg3 rte)))) + +(define (gen-combination-n oper args) + (lambda (rte) + (define (evaluate l rte) + (if (pair? l) + (cons ((car l) rte) (evaluate (cdr l) rte)) + '())) + (apply (oper rte) (evaluate args rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-comp expr env) + (cond ((symbol? expr) + (comp-var expr env)) + ((not (pair? expr)) + (comp-self-eval expr env)) + ((macro? (car expr) env) + (scheme-comp (macro-expand expr env) env)) + (else + (cond + ((eq? (car expr) 'quote) (comp-quote expr env)) + ((eq? (car expr) 'quasiquote) (comp-quasiquote expr env)) + ((eq? (car expr) 'unquote) (comp-unquote expr env)) + ((eq? (car expr) 'unquote-splicing) (comp-unquote-splicing expr env)) + ((eq? (car expr) 'set!) (comp-set! expr env)) + ((eq? (car expr) 'lambda) (comp-lambda expr env)) + ((eq? (car expr) 'if) (comp-if expr env)) + ((eq? (car expr) 'cond) (comp-cond expr env)) + ((eq? (car expr) 'and) (comp-and expr env)) + ((eq? (car expr) 'or) (comp-or expr env)) + ((eq? (car expr) 'case) (comp-case expr env)) + ((eq? (car expr) 'let) (comp-let expr env)) + ((eq? (car expr) 'let*) (comp-let* expr env)) + ((eq? (car expr) 'letrec) (comp-letrec expr env)) + ((eq? (car expr) 'begin) (comp-begin expr env)) + ((eq? (car expr) 'do) (comp-do expr env)) + ((eq? (car expr) 'define) (comp-define expr env)) + ((eq? (car expr) 'define-macro) (comp-define-macro expr env)) + (else (comp-combination expr env)))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-global-var name) + (let ((x (assq name scheme-global-variables))) + (if x + x + (let ((y (cons name '()))) + (set! scheme-global-variables (cons y scheme-global-variables)) + y)))) + +(define (scheme-global-var-ref i) + (cdr i)) + +(define (scheme-global-var-set! i val) + (set-cdr! i val) + '()) + +(define scheme-global-variables '()) + +(define (def-proc name value) + (scheme-global-var-set! + (scheme-global-var name) + value)) + +(define nothing + (begin +(def-proc 'not (lambda (x) (not x))) +(def-proc 'boolean? boolean?) +(def-proc 'eqv? eqv?) +(def-proc 'eq? eq?) +(def-proc 'equal? equal?) +(def-proc 'pair? (lambda (obj) (pair? obj))) +(def-proc 'cons (lambda (x y) (cons x y))) +(def-proc 'car (lambda (x) (car x))) +(def-proc 'cdr (lambda (x) (cdr x))) +(def-proc 'set-car! set-car!) +(def-proc 'set-cdr! set-cdr!) +(def-proc 'caar caar) +(def-proc 'cadr cadr) +(def-proc 'cdar cdar) +(def-proc 'cddr cddr) +(def-proc 'caaar caaar) +(def-proc 'caadr caadr) +(def-proc 'cadar cadar) +(def-proc 'caddr caddr) +(def-proc 'cdaar cdaar) +(def-proc 'cdadr cdadr) +(def-proc 'cddar cddar) +(def-proc 'cdddr cdddr) +(def-proc 'caaaar caaaar) +(def-proc 'caaadr caaadr) +(def-proc 'caadar caadar) +(def-proc 'caaddr caaddr) +(def-proc 'cadaar cadaar) +(def-proc 'cadadr cadadr) +(def-proc 'caddar caddar) +(def-proc 'cadddr cadddr) +(def-proc 'cdaaar cdaaar) +(def-proc 'cdaadr cdaadr) +(def-proc 'cdadar cdadar) +(def-proc 'cdaddr cdaddr) +(def-proc 'cddaar cddaar) +(def-proc 'cddadr cddadr) +(def-proc 'cdddar cdddar) +(def-proc 'cddddr cddddr) +(def-proc 'null? (lambda (x) (null? x))) +(def-proc 'list? list?) +(def-proc 'list list) +(def-proc 'length length) +(def-proc 'append append) +(def-proc 'reverse reverse) +(def-proc 'list-ref list-ref) +(def-proc 'memq memq) +(def-proc 'memv memv) +(def-proc 'member member) +(def-proc 'assq assq) +(def-proc 'assv assv) +(def-proc 'assoc assoc) +(def-proc 'symbol? symbol?) +(def-proc 'symbol->string symbol->string) +(def-proc 'string->symbol string->symbol) +(def-proc 'number? number?) +(def-proc 'complex? complex?) +(def-proc 'real? real?) +(def-proc 'rational? rational?) +(def-proc 'integer? integer?) +(def-proc 'exact? exact?) +(def-proc 'inexact? inexact?) +;(def-proc '= =) +;(def-proc '< <) +;(def-proc '> >) +;(def-proc '<= <=) +;(def-proc '>= >=) +;(def-proc 'zero? zero?) +;(def-proc 'positive? positive?) +;(def-proc 'negative? negative?) +;(def-proc 'odd? odd?) +;(def-proc 'even? even?) +(def-proc 'max max) +(def-proc 'min min) +;(def-proc '+ +) +;(def-proc '* *) +;(def-proc '- -) +(def-proc '/ /) +(def-proc 'abs abs) +;(def-proc 'quotient quotient) +;(def-proc 'remainder remainder) +;(def-proc 'modulo modulo) +(def-proc 'gcd gcd) +(def-proc 'lcm lcm) +;(def-proc 'numerator numerator) +;(def-proc 'denominator denominator) +(def-proc 'floor floor) +(def-proc 'ceiling ceiling) +(def-proc 'truncate truncate) +(def-proc 'round round) +;(def-proc 'rationalize rationalize) +(def-proc 'exp exp) +(def-proc 'log log) +(def-proc 'sin sin) +(def-proc 'cos cos) +(def-proc 'tan tan) +(def-proc 'asin asin) +(def-proc 'acos acos) +(def-proc 'atan atan) +(def-proc 'sqrt sqrt) +(def-proc 'expt expt) +;(def-proc 'make-rectangular make-rectangular) +;(def-proc 'make-polar make-polar) +;(def-proc 'real-part real-part) +;(def-proc 'imag-part imag-part) +;(def-proc 'magnitude magnitude) +;(def-proc 'angle angle) +(def-proc 'exact->inexact exact->inexact) +(def-proc 'inexact->exact inexact->exact) +(def-proc 'number->string number->string) +(def-proc 'string->number string->number) +(def-proc 'char? char?) +(def-proc 'char=? char=?) +(def-proc 'char? char>?) +(def-proc 'char<=? char<=?) +(def-proc 'char>=? char>=?) +(def-proc 'char-ci=? char-ci=?) +(def-proc 'char-ci? char-ci>?) +(def-proc 'char-ci<=? char-ci<=?) +(def-proc 'char-ci>=? char-ci>=?) +(def-proc 'char-alphabetic? char-alphabetic?) +(def-proc 'char-numeric? char-numeric?) +(def-proc 'char-whitespace? char-whitespace?) +(def-proc 'char-lower-case? char-lower-case?) +(def-proc 'char->integer char->integer) +(def-proc 'integer->char integer->char) +(def-proc 'char-upcase char-upcase) +(def-proc 'char-downcase char-downcase) +(def-proc 'string? string?) +(def-proc 'make-string make-string) +(def-proc 'string string) +(def-proc 'string-length string-length) +(def-proc 'string-ref string-ref) +(def-proc 'string-set! string-set!) +(def-proc 'string=? string=?) +(def-proc 'string? string>?) +(def-proc 'string<=? string<=?) +(def-proc 'string>=? string>=?) +(def-proc 'string-ci=? string-ci=?) +(def-proc 'string-ci? string-ci>?) +(def-proc 'string-ci<=? string-ci<=?) +(def-proc 'string-ci>=? string-ci>=?) +(def-proc 'substring substring) +(def-proc 'string-append string-append) +(def-proc 'vector? vector?) +(def-proc 'make-vector make-vector) +(def-proc 'vector vector) +(def-proc 'vector-length vector-length) +(def-proc 'vector-ref vector-ref) +(def-proc 'vector-set! vector-set!) +(def-proc 'procedure? procedure?) +(def-proc 'apply apply) +(def-proc 'map map) +(def-proc 'for-each for-each) +;(def-proc 'call-with-current-continuation call-with-current-continuation) +(def-proc 'call-with-input-file call-with-input-file) +(def-proc 'call-with-output-file call-with-output-file) +(def-proc 'input-port? input-port?) +(def-proc 'output-port? output-port?) +(def-proc 'current-input-port current-input-port) +(def-proc 'current-output-port current-output-port) +(def-proc 'open-input-file open-input-file) +(def-proc 'open-output-file open-output-file) +(def-proc 'close-input-port close-input-port) +(def-proc 'close-output-port close-output-port) +(def-proc 'eof-object? eof-object?) +(def-proc 'read read) +(def-proc 'read-char read-char) +(def-proc 'peek-char peek-char) +(def-proc 'write write) +(def-proc 'display display) +(def-proc 'newline newline) +(def-proc 'write-char write-char))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define expr1 + '(let () + + (define (sort-list obj pred) + + (define (loop l) + (if (and (pair? l) (pair? (cdr l))) + (split l '() '()) + l)) + + (define (split l one two) + (if (pair? l) + (split (cdr l) two (cons (car l) one)) + (merge (loop one) (loop two)))) + + (define (merge one two) + (cond ((null? one) two) + ((pred (car two) (car one)) + (cons (car two) + (merge (cdr two) one))) + (else + (cons (car one) + (merge (cdr one) two))))) + + (loop obj)) + + (sort-list '("one" "two" "three" "four" "five" "six" + "seven" "eight" "nine" "ten" "eleven" "twelve") + stringvector l) + (let* ((n (length l)) + (v (make-vector n))) + (let loop ((l l) (i 0)) + (if (pair? l) + (begin + (vector-set! v i (car l)) + (loop (cdr l) (+ i 1))) + v)))) + +(define (vector->lst v) + (let loop ((l '()) (i (- (vector-length v) 1))) + (if (< i 0) + l + (loop (cons (vector-ref v i) l) (- i 1))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define scheme-syntactic-keywords + '(quote quasiquote unquote unquote-splicing + lambda if set! cond => else and or + case let let* letrec begin do define + define-macro)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (push-frame frame env) + (if (null? frame) + env + (cons (cons (car env) frame) (cdr env)))) + +(define (lookup-var name env) + (let loop1 ((chain (car env)) (up 0)) + (if (null? chain) + name + (let loop2 ((chain chain) + (up up) + (frame (cdr chain)) + (over 1)) + (cond ((null? frame) + (loop1 (car chain) (+ up 1))) + ((eq? (car frame) name) + (cons up over)) + (else + (loop2 chain up (cdr frame) (+ over 1)))))))) + +(define (macro? name env) + (assq name (cdr env))) + +(define (push-macro name proc env) + (cons (car env) (cons (cons name proc) (cdr env)))) + +(define (lookup-macro name env) + (cdr (assq name (cdr env)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (variable x) + (if (not (symbol? x)) + (scheme-error "Identifier expected" x)) + (if (memq x scheme-syntactic-keywords) + (scheme-error "Variable name can not be a syntactic keyword" x))) + +(define (shape form n) + (let loop ((form form) (n n) (l form)) + (cond ((<= n 0)) + ((pair? l) + (loop form (- n 1) (cdr l))) + (else + (scheme-error "Ill-constructed form" form))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (macro-expand expr env) + (apply (lookup-macro (car expr) env) (cdr expr))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-var expr env) + (variable expr) + (gen-var-ref (lookup-var expr env))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-self-eval expr env) + (gen-cst expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-quote expr env) + (shape expr 2) + (gen-cst (cadr expr))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-quasiquote expr env) + (comp-quasiquotation (cadr expr) 1 env)) + +(define (comp-quasiquotation form level env) + (cond ((= level 0) + (scheme-comp form env)) + ((pair? form) + (cond + ((eq? (car form) 'quasiquote) + (comp-quasiquotation-list form (+ level 1) env)) + ((eq? (car form) 'unquote) + (if (= level 1) + (scheme-comp (cadr form) env) + (comp-quasiquotation-list form (- level 1) env))) + ((eq? (car form) 'unquote-splicing) + (if (= level 1) + (scheme-error "Ill-placed 'unquote-splicing'" form)) + (comp-quasiquotation-list form (- level 1) env)) + (else + (comp-quasiquotation-list form level env)))) + ((vector? form) + (gen-vector-form + (comp-quasiquotation-list (vector->lst form) level env))) + (else + (gen-cst form)))) + +(define (comp-quasiquotation-list l level env) + (if (pair? l) + (let ((first (car l))) + (if (= level 1) + (if (unquote-splicing? first) + (begin + (shape first 2) + (gen-append-form (scheme-comp (cadr first) env) + (comp-quasiquotation (cdr l) 1 env))) + (gen-cons-form (comp-quasiquotation first level env) + (comp-quasiquotation (cdr l) level env))) + (gen-cons-form (comp-quasiquotation first level env) + (comp-quasiquotation (cdr l) level env)))) + (comp-quasiquotation l level env))) + +(define (unquote-splicing? x) + (if (pair? x) + (if (eq? (car x) 'unquote-splicing) #t #f) + #f)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-unquote expr env) + (scheme-error "Ill-placed 'unquote'" expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-unquote-splicing expr env) + (scheme-error "Ill-placed 'unquote-splicing'" expr)) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-set! expr env) + (shape expr 3) + (variable (cadr expr)) + (gen-var-set (lookup-var (cadr expr) env) (scheme-comp (caddr expr) env))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-lambda expr env) + (shape expr 3) + (let ((parms (cadr expr))) + (let ((frame (parms->frame parms))) + (let ((nb-vars (length frame)) + (code (comp-body (cddr expr) (push-frame frame env)))) + (if (rest-param? parms) + (gen-lambda-rest nb-vars code) + (gen-lambda nb-vars code)))))) + +(define (parms->frame parms) + (cond ((null? parms) + '()) + ((pair? parms) + (let ((x (car parms))) + (variable x) + (cons x (parms->frame (cdr parms))))) + (else + (variable parms) + (list parms)))) + +(define (rest-param? parms) + (cond ((pair? parms) + (rest-param? (cdr parms))) + ((null? parms) + #f) + (else + #t))) + +(define (comp-body body env) + + (define (letrec-defines vars vals body env) + (if (pair? body) + + (let ((expr (car body))) + (cond ((not (pair? expr)) + (letrec-defines* vars vals body env)) + ((macro? (car expr) env) + (letrec-defines vars + vals + (cons (macro-expand expr env) (cdr body)) + env)) + (else + (cond + ((eq? (car expr) 'begin) + (letrec-defines vars + vals + (append (cdr expr) (cdr body)) + env)) + ((eq? (car expr) 'define) + (let ((x (definition-name expr))) + (variable x) + (letrec-defines (cons x vars) + (cons (definition-value expr) vals) + (cdr body) + env))) + ((eq? (car expr) 'define-macro) + (let ((x (definition-name expr))) + (letrec-defines vars + vals + (cdr body) + (push-macro + x + (scheme-eval (definition-value expr)) + env)))) + (else + (letrec-defines* vars vals body env)))))) + + (scheme-error "Body must contain at least one evaluable expression"))) + + (define (letrec-defines* vars vals body env) + (if (null? vars) + (comp-sequence body env) + (comp-letrec-aux vars vals body env))) + + (letrec-defines '() '() body env)) + +(define (definition-name expr) + (shape expr 3) + (let ((pattern (cadr expr))) + (let ((name (if (pair? pattern) (car pattern) pattern))) + (if (not (symbol? name)) + (scheme-error "Identifier expected" name)) + name))) + +(define (definition-value expr) + (let ((pattern (cadr expr))) + (if (pair? pattern) + (cons 'lambda (cons (cdr pattern) (cddr expr))) + (caddr expr)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-if expr env) + (shape expr 3) + (let ((code1 (scheme-comp (cadr expr) env)) + (code2 (scheme-comp (caddr expr) env))) + (if (pair? (cdddr expr)) + (gen-if code1 code2 (scheme-comp (cadddr expr) env)) + (gen-when code1 code2)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-cond expr env) + (comp-cond-aux (cdr expr) env)) + +(define (comp-cond-aux clauses env) + (if (pair? clauses) + (let ((clause (car clauses))) + (shape clause 1) + (cond ((eq? (car clause) 'else) + (shape clause 2) + (comp-sequence (cdr clause) env)) + ((not (pair? (cdr clause))) + (gen-or (scheme-comp (car clause) env) + (comp-cond-aux (cdr clauses) env))) + ((eq? (cadr clause) '=>) + (shape clause 3) + (gen-cond-send (scheme-comp (car clause) env) + (scheme-comp (caddr clause) env) + (comp-cond-aux (cdr clauses) env))) + (else + (gen-if (scheme-comp (car clause) env) + (comp-sequence (cdr clause) env) + (comp-cond-aux (cdr clauses) env))))) + (gen-cst '()))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-and expr env) + (let ((rest (cdr expr))) + (if (pair? rest) (comp-and-aux rest env) (gen-cst #t)))) + +(define (comp-and-aux l env) + (let ((code (scheme-comp (car l) env)) + (rest (cdr l))) + (if (pair? rest) (gen-and code (comp-and-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-or expr env) + (let ((rest (cdr expr))) + (if (pair? rest) (comp-or-aux rest env) (gen-cst #f)))) + +(define (comp-or-aux l env) + (let ((code (scheme-comp (car l) env)) + (rest (cdr l))) + (if (pair? rest) (gen-or code (comp-or-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-case expr env) + (shape expr 3) + (gen-case (scheme-comp (cadr expr) env) + (comp-case-aux (cddr expr) env))) + +(define (comp-case-aux clauses env) + (if (pair? clauses) + (let ((clause (car clauses))) + (shape clause 2) + (if (eq? (car clause) 'else) + (gen-case-else (comp-sequence (cdr clause) env)) + (gen-case-clause (car clause) + (comp-sequence (cdr clause) env) + (comp-case-aux (cdr clauses) env)))) + (gen-case-else (gen-cst '())))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-let expr env) + (shape expr 3) + (let ((x (cadr expr))) + (cond ((symbol? x) + (shape expr 4) + (let ((y (caddr expr))) + (let ((proc (cons 'lambda (cons (bindings->vars y) (cdddr expr))))) + (scheme-comp (cons (list 'letrec (list (list x proc)) x) + (bindings->vals y)) + env)))) + ((pair? x) + (scheme-comp (cons (cons 'lambda (cons (bindings->vars x) (cddr expr))) + (bindings->vals x)) + env)) + (else + (comp-body (cddr expr) env))))) + +(define (bindings->vars bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (shape binding 2) + (let ((x (car binding))) + (variable x) + (cons x (bindings->vars (cdr bindings))))) + '())) + +(define (bindings->vals bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (cons (cadr binding) (bindings->vals (cdr bindings)))) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-let* expr env) + (shape expr 3) + (let ((bindings (cadr expr))) + (if (pair? bindings) + (scheme-comp (list 'let + (list (car bindings)) + (cons 'let* (cons (cdr bindings) (cddr expr)))) + env) + (comp-body (cddr expr) env)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-letrec expr env) + (shape expr 3) + (let ((bindings (cadr expr))) + (comp-letrec-aux (bindings->vars bindings) + (bindings->vals bindings) + (cddr expr) + env))) + +(define (comp-letrec-aux vars vals body env) + (if (pair? vars) + (let ((new-env (push-frame vars env))) + (gen-letrec (comp-vals vals new-env) + (comp-body body new-env))) + (comp-body body env))) + +(define (comp-vals l env) + (if (pair? l) + (cons (scheme-comp (car l) env) (comp-vals (cdr l) env)) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-begin expr env) + (shape expr 2) + (comp-sequence (cdr expr) env)) + +(define (comp-sequence exprs env) + (if (pair? exprs) + (comp-sequence-aux exprs env) + (gen-cst '()))) + +(define (comp-sequence-aux exprs env) + (let ((code (scheme-comp (car exprs) env)) + (rest (cdr exprs))) + (if (pair? rest) (gen-sequence code (comp-sequence-aux rest env)) code))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-do expr env) + (shape expr 3) + (let ((bindings (cadr expr)) + (exit (caddr expr))) + (shape exit 1) + (let* ((vars (bindings->vars bindings)) + (new-env1 (push-frame '(#f) env)) + (new-env2 (push-frame vars new-env1))) + (gen-letrec + (list + (gen-lambda + (length vars) + (gen-if + (scheme-comp (car exit) new-env2) + (comp-sequence (cdr exit) new-env2) + (gen-sequence + (comp-sequence (cdddr expr) new-env2) + (gen-combination + (gen-var-ref '(1 . 1)) + (comp-vals (bindings->steps bindings) new-env2)))))) + (gen-combination + (gen-var-ref '(0 . 1)) + (comp-vals (bindings->vals bindings) new-env1)))))) + +(define (bindings->steps bindings) + (if (pair? bindings) + (let ((binding (car bindings))) + (cons (if (pair? (cddr binding)) (caddr binding) (car binding)) + (bindings->steps (cdr bindings)))) + '())) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-define expr env) + (shape expr 3) + (let ((pattern (cadr expr))) + (let ((x (if (pair? pattern) (car pattern) pattern))) + (variable x) + (gen-sequence + (gen-var-set (lookup-var x env) + (scheme-comp (if (pair? pattern) + (cons 'lambda (cons (cdr pattern) (cddr expr))) + (caddr expr)) + env)) + (gen-cst x))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-define-macro expr env) + (let ((x (definition-name expr))) + (gen-macro x (scheme-eval (definition-value expr))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (comp-combination expr env) + (gen-combination (scheme-comp (car expr) env) (comp-vals (cdr expr) env))) + +;------------------------------------------------------------------------------ + +(define (gen-var-ref var) + (if (pair? var) + (gen-rte-ref (car var) (cdr var)) + (gen-glo-ref (scheme-global-var var)))) + +(define (gen-rte-ref up over) + (case up + ((0) (gen-slot-ref-0 over)) + ((1) (gen-slot-ref-1 over)) + (else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over))))) + +(define (gen-slot-ref-0 i) + (case i + ((0) (lambda (rte) (vector-ref rte 0))) + ((1) (lambda (rte) (vector-ref rte 1))) + ((2) (lambda (rte) (vector-ref rte 2))) + ((3) (lambda (rte) (vector-ref rte 3))) + (else (lambda (rte) (vector-ref rte i))))) + +(define (gen-slot-ref-1 i) + (case i + ((0) (lambda (rte) (vector-ref (vector-ref rte 0) 0))) + ((1) (lambda (rte) (vector-ref (vector-ref rte 0) 1))) + ((2) (lambda (rte) (vector-ref (vector-ref rte 0) 2))) + ((3) (lambda (rte) (vector-ref (vector-ref rte 0) 3))) + (else (lambda (rte) (vector-ref (vector-ref rte 0) i))))) + +(define (gen-slot-ref-up-2 code) + (lambda (rte) (code (vector-ref (vector-ref rte 0) 0)))) + +(define (gen-glo-ref i) + (lambda (rte) (scheme-global-var-ref i))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-cst val) + (case val + ((()) (lambda (rte) '())) + ((#f) (lambda (rte) #f)) + ((#t) (lambda (rte) #t)) + ((-2) (lambda (rte) -2)) + ((-1) (lambda (rte) -1)) + ((0) (lambda (rte) 0)) + ((1) (lambda (rte) 1)) + ((2) (lambda (rte) 2)) + (else (lambda (rte) val)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-append-form code1 code2) + (lambda (rte) (append (code1 rte) (code2 rte)))) + +(define (gen-cons-form code1 code2) + (lambda (rte) (cons (code1 rte) (code2 rte)))) + +(define (gen-vector-form code) + (lambda (rte) (lst->vector (code rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-var-set var code) + (if (pair? var) + (gen-rte-set (car var) (cdr var) code) + (gen-glo-set (scheme-global-var var) code))) + +(define (gen-rte-set up over code) + (case up + ((0) (gen-slot-set-0 over code)) + ((1) (gen-slot-set-1 over code)) + (else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code)))) + +(define (gen-slot-set-0 i code) + (case i + ((0) (lambda (rte) (vector-set! rte 0 (code rte)))) + ((1) (lambda (rte) (vector-set! rte 1 (code rte)))) + ((2) (lambda (rte) (vector-set! rte 2 (code rte)))) + ((3) (lambda (rte) (vector-set! rte 3 (code rte)))) + (else (lambda (rte) (vector-set! rte i (code rte)))))) + +(define (gen-slot-set-1 i code) + (case i + ((0) (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte)))) + ((1) (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte)))) + ((2) (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte)))) + ((3) (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte)))) + (else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte)))))) + +(define (gen-slot-set-n up i code) + (case i + ((0) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte)))) + ((1) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte)))) + ((2) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte)))) + ((3) (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte)))) + (else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte)))))) + +(define (gen-glo-set i code) + (lambda (rte) (scheme-global-var-set! i (code rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-lambda-rest nb-vars body) + (case nb-vars + ((1) (gen-lambda-1-rest body)) + ((2) (gen-lambda-2-rest body)) + ((3) (gen-lambda-3-rest body)) + (else (gen-lambda-n-rest nb-vars body)))) + +(define (gen-lambda-1-rest body) + (lambda (rte) + (lambda a + (body (vector rte a))))) + +(define (gen-lambda-2-rest body) + (lambda (rte) + (lambda (a . b) + (body (vector rte a b))))) + +(define (gen-lambda-3-rest body) + (lambda (rte) + (lambda (a b . c) + (body (vector rte a b c))))) + +(define (gen-lambda-n-rest nb-vars body) + (lambda (rte) + (lambda (a b c . d) + (let ((x (make-vector (+ nb-vars 1)))) + (vector-set! x 0 rte) + (vector-set! x 1 a) + (vector-set! x 2 b) + (vector-set! x 3 c) + (let loop ((n nb-vars) (x x) (i 4) (l d)) + (if (< i n) + (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))) + (vector-set! x i l))) + (body x))))) + +(define (gen-lambda nb-vars body) + (case nb-vars + ((0) (gen-lambda-0 body)) + ((1) (gen-lambda-1 body)) + ((2) (gen-lambda-2 body)) + ((3) (gen-lambda-3 body)) + (else (gen-lambda-n nb-vars body)))) + +(define (gen-lambda-0 body) + (lambda (rte) + (lambda () + (body rte)))) + +(define (gen-lambda-1 body) + (lambda (rte) + (lambda (a) + (body (vector rte a))))) + +(define (gen-lambda-2 body) + (lambda (rte) + (lambda (a b) + (body (vector rte a b))))) + +(define (gen-lambda-3 body) + (lambda (rte) + (lambda (a b c) + (body (vector rte a b c))))) + +(define (gen-lambda-n nb-vars body) + (lambda (rte) + (lambda (a b c . d) + (let ((x (make-vector (+ nb-vars 1)))) + (vector-set! x 0 rte) + (vector-set! x 1 a) + (vector-set! x 2 b) + (vector-set! x 3 c) + (let loop ((n nb-vars) (x x) (i 4) (l d)) + (if (<= i n) + (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l))))) + (body x))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-sequence code1 code2) + (lambda (rte) (code1 rte) (code2 rte))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-when code1 code2) + (lambda (rte) + (if (code1 rte) + (code2 rte) + '()))) + +(define (gen-if code1 code2 code3) + (lambda (rte) + (if (code1 rte) + (code2 rte) + (code3 rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-cond-send code1 code2 code3) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + ((code2 rte) temp) + (code3 rte))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-and code1 code2) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + (code2 rte) + temp)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-or code1 code2) + (lambda (rte) + (let ((temp (code1 rte))) + (if temp + temp + (code2 rte))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-case code1 code2) + (lambda (rte) (code2 rte (code1 rte)))) + +(define (gen-case-clause datums code1 code2) + (lambda (rte key) (if (memv key datums) (code1 rte) (code2 rte key)))) + +(define (gen-case-else code) + (lambda (rte key) (code rte))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-letrec vals body) + (let ((nb-vals (length vals))) + (case nb-vals + ((1) (gen-letrec-1 (car vals) body)) + ((2) (gen-letrec-2 (car vals) (cadr vals) body)) + ((3) (gen-letrec-3 (car vals) (cadr vals) (caddr vals) body)) + (else (gen-letrec-n nb-vals vals body))))) + +(define (gen-letrec-1 val1 body) + (lambda (rte) + (let ((x (vector rte #f))) + (vector-set! x 1 (val1 x)) + (body x)))) + +(define (gen-letrec-2 val1 val2 body) + (lambda (rte) + (let ((x (vector rte #f #f))) + (vector-set! x 1 (val1 x)) + (vector-set! x 2 (val2 x)) + (body x)))) + +(define (gen-letrec-3 val1 val2 val3 body) + (lambda (rte) + (let ((x (vector rte #f #f #f))) + (vector-set! x 1 (val1 x)) + (vector-set! x 2 (val2 x)) + (vector-set! x 3 (val3 x)) + (body x)))) + +(define (gen-letrec-n nb-vals vals body) + (lambda (rte) + (let ((x (make-vector (+ nb-vals 1)))) + (vector-set! x 0 rte) + (let loop ((x x) (i 1) (l vals)) + (if (pair? l) + (begin (vector-set! x i ((car l) x)) (loop x (+ i 1) (cdr l))))) + (body x)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-macro name proc) + (lambda (rte) (scheme-add-macro name proc))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (gen-combination oper args) + (case (length args) + ((0) (gen-combination-0 oper)) + ((1) (gen-combination-1 oper (car args))) + ((2) (gen-combination-2 oper (car args) (cadr args))) + ((3) (gen-combination-3 oper (car args) (cadr args) (caddr args))) + (else (gen-combination-n oper args)))) + +(define (gen-combination-0 oper) + (lambda (rte) ((oper rte)))) + +(define (gen-combination-1 oper arg1) + (lambda (rte) ((oper rte) (arg1 rte)))) + +(define (gen-combination-2 oper arg1 arg2) + (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte)))) + +(define (gen-combination-3 oper arg1 arg2 arg3) + (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte) (arg3 rte)))) + +(define (gen-combination-n oper args) + (lambda (rte) + (define (evaluate l rte) + (if (pair? l) + (cons ((car l) rte) (evaluate (cdr l) rte)) + '())) + (apply (oper rte) (evaluate args rte)))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-comp expr env) + (cond ((symbol? expr) + (comp-var expr env)) + ((not (pair? expr)) + (comp-self-eval expr env)) + ((macro? (car expr) env) + (scheme-comp (macro-expand expr env) env)) + (else + (cond + ((eq? (car expr) 'quote) (comp-quote expr env)) + ((eq? (car expr) 'quasiquote) (comp-quasiquote expr env)) + ((eq? (car expr) 'unquote) (comp-unquote expr env)) + ((eq? (car expr) 'unquote-splicing) (comp-unquote-splicing expr env)) + ((eq? (car expr) 'set!) (comp-set! expr env)) + ((eq? (car expr) 'lambda) (comp-lambda expr env)) + ((eq? (car expr) 'if) (comp-if expr env)) + ((eq? (car expr) 'cond) (comp-cond expr env)) + ((eq? (car expr) 'and) (comp-and expr env)) + ((eq? (car expr) 'or) (comp-or expr env)) + ((eq? (car expr) 'case) (comp-case expr env)) + ((eq? (car expr) 'let) (comp-let expr env)) + ((eq? (car expr) 'let*) (comp-let* expr env)) + ((eq? (car expr) 'letrec) (comp-letrec expr env)) + ((eq? (car expr) 'begin) (comp-begin expr env)) + ((eq? (car expr) 'do) (comp-do expr env)) + ((eq? (car expr) 'define) (comp-define expr env)) + ((eq? (car expr) 'define-macro) (comp-define-macro expr env)) + (else (comp-combination expr env)))))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define (scheme-global-var name) + (let ((x (assq name scheme-global-variables))) + (if x + (cdr x) + (let ((y (vector '()))) + (set! scheme-global-variables (cons (cons name y) scheme-global-variables)) + y)))) + +(define (scheme-global-var-ref i) + (vector-ref i 0)) + +(define (scheme-global-var-set! i val) + (vector-set! i 0 val) + '()) + +(define scheme-global-variables '()) + +(define (def-proc name value) + (scheme-global-var-set! + (scheme-global-var name) + value)) + +(define nothing + (begin +(def-proc 'not (lambda (x) (not x))) +(def-proc 'boolean? boolean?) +(def-proc 'eqv? eqv?) +(def-proc 'eq? eq?) +(def-proc 'equal? equal?) +(def-proc 'pair? (lambda (obj) (pair? obj))) +(def-proc 'cons (lambda (x y) (cons x y))) +(def-proc 'car (lambda (x) (car x))) +(def-proc 'cdr (lambda (x) (cdr x))) +;(def-proc 'set-car! set-car!) +;(def-proc 'set-cdr! set-cdr!) +(def-proc 'caar caar) +(def-proc 'cadr cadr) +(def-proc 'cdar cdar) +(def-proc 'cddr cddr) +(def-proc 'caaar caaar) +(def-proc 'caadr caadr) +(def-proc 'cadar cadar) +(def-proc 'caddr caddr) +(def-proc 'cdaar cdaar) +(def-proc 'cdadr cdadr) +(def-proc 'cddar cddar) +(def-proc 'cdddr cdddr) +(def-proc 'caaaar caaaar) +(def-proc 'caaadr caaadr) +(def-proc 'caadar caadar) +(def-proc 'caaddr caaddr) +(def-proc 'cadaar cadaar) +(def-proc 'cadadr cadadr) +(def-proc 'caddar caddar) +(def-proc 'cadddr cadddr) +(def-proc 'cdaaar cdaaar) +(def-proc 'cdaadr cdaadr) +(def-proc 'cdadar cdadar) +(def-proc 'cdaddr cdaddr) +(def-proc 'cddaar cddaar) +(def-proc 'cddadr cddadr) +(def-proc 'cdddar cdddar) +(def-proc 'cddddr cddddr) +(def-proc 'null? (lambda (x) (null? x))) +(def-proc 'list? list?) +(def-proc 'list list) +(def-proc 'length length) +(def-proc 'append append) +(def-proc 'reverse reverse) +(def-proc 'list-ref list-ref) +(def-proc 'memq memq) +(def-proc 'memv memv) +(def-proc 'member member) +(def-proc 'assq assq) +(def-proc 'assv assv) +(def-proc 'assoc assoc) +(def-proc 'symbol? symbol?) +(def-proc 'symbol->string symbol->string) +(def-proc 'string->symbol string->symbol) +(def-proc 'number? number?) +(def-proc 'complex? complex?) +(def-proc 'real? real?) +(def-proc 'rational? rational?) +(def-proc 'integer? integer?) +(def-proc 'exact? exact?) +(def-proc 'inexact? inexact?) +;(def-proc '= =) +;(def-proc '< <) +;(def-proc '> >) +;(def-proc '<= <=) +;(def-proc '>= >=) +;(def-proc 'zero? zero?) +;(def-proc 'positive? positive?) +;(def-proc 'negative? negative?) +;(def-proc 'odd? odd?) +;(def-proc 'even? even?) +(def-proc 'max max) +(def-proc 'min min) +;(def-proc '+ +) +;(def-proc '* *) +;(def-proc '- -) +(def-proc '/ /) +(def-proc 'abs abs) +;(def-proc 'quotient quotient) +;(def-proc 'remainder remainder) +;(def-proc 'modulo modulo) +(def-proc 'gcd gcd) +(def-proc 'lcm lcm) +;(def-proc 'numerator numerator) +;(def-proc 'denominator denominator) +(def-proc 'floor floor) +(def-proc 'ceiling ceiling) +(def-proc 'truncate truncate) +(def-proc 'round round) +;(def-proc 'rationalize rationalize) +(def-proc 'exp exp) +(def-proc 'log log) +(def-proc 'sin sin) +(def-proc 'cos cos) +(def-proc 'tan tan) +(def-proc 'asin asin) +(def-proc 'acos acos) +(def-proc 'atan atan) +(def-proc 'sqrt sqrt) +(def-proc 'expt expt) +;(def-proc 'make-rectangular make-rectangular) +;(def-proc 'make-polar make-polar) +;(def-proc 'real-part real-part) +;(def-proc 'imag-part imag-part) +;(def-proc 'magnitude magnitude) +;(def-proc 'angle angle) +(def-proc 'exact->inexact exact->inexact) +(def-proc 'inexact->exact inexact->exact) +(def-proc 'number->string number->string) +(def-proc 'string->number string->number) +(def-proc 'char? char?) +(def-proc 'char=? char=?) +(def-proc 'char? char>?) +(def-proc 'char<=? char<=?) +(def-proc 'char>=? char>=?) +(def-proc 'char-ci=? char-ci=?) +(def-proc 'char-ci? char-ci>?) +(def-proc 'char-ci<=? char-ci<=?) +(def-proc 'char-ci>=? char-ci>=?) +(def-proc 'char-alphabetic? char-alphabetic?) +(def-proc 'char-numeric? char-numeric?) +(def-proc 'char-whitespace? char-whitespace?) +(def-proc 'char-lower-case? char-lower-case?) +(def-proc 'char->integer char->integer) +(def-proc 'integer->char integer->char) +(def-proc 'char-upcase char-upcase) +(def-proc 'char-downcase char-downcase) +(def-proc 'string? string?) +(def-proc 'make-string make-string) +(def-proc 'string string) +(def-proc 'string-length string-length) +(def-proc 'string-ref string-ref) +(def-proc 'string-set! string-set!) +(def-proc 'string=? string=?) +(def-proc 'string? string>?) +(def-proc 'string<=? string<=?) +(def-proc 'string>=? string>=?) +(def-proc 'string-ci=? string-ci=?) +(def-proc 'string-ci? string-ci>?) +(def-proc 'string-ci<=? string-ci<=?) +(def-proc 'string-ci>=? string-ci>=?) +(def-proc 'substring substring) +(def-proc 'string-append string-append) +(def-proc 'vector? vector?) +(def-proc 'make-vector make-vector) +(def-proc 'vector vector) +(def-proc 'vector-length vector-length) +(def-proc 'vector-ref vector-ref) +(def-proc 'vector-set! vector-set!) +(def-proc 'procedure? procedure?) +(def-proc 'apply apply) +(def-proc 'map map) +(def-proc 'for-each for-each) +;(def-proc 'call-with-current-continuation call-with-current-continuation) +(def-proc 'call-with-input-file call-with-input-file) +(def-proc 'call-with-output-file call-with-output-file) +(def-proc 'input-port? input-port?) +(def-proc 'output-port? output-port?) +(def-proc 'current-input-port current-input-port) +(def-proc 'current-output-port current-output-port) +(def-proc 'open-input-file open-input-file) +(def-proc 'open-output-file open-output-file) +(def-proc 'close-input-port close-input-port) +(def-proc 'close-output-port close-output-port) +(def-proc 'eof-object? eof-object?) +(def-proc 'read read) +(def-proc 'read-char read-char) +(def-proc 'peek-char peek-char) +(def-proc 'write write) +(def-proc 'display display) +(def-proc 'newline newline) +(def-proc 'write-char write-char))) + +; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +(define expr1 + '(let () + + (define (sort-list obj pred) + + (define (loop l) + (if (and (pair? l) (pair? (cdr l))) + (split l '() '()) + l)) + + (define (split l one two) + (if (pair? l) + (split (cdr l) two (cons (car l) one)) + (merge (loop one) (loop two)))) + + (define (merge one two) + (cond ((null? one) two) + ((pred (car two) (car one)) + (cons (car two) + (merge (cdr two) one))) + (else + (cons (car one) + (merge (cdr one) two))))) + + (loop obj)) + + (sort-list '("one" "two" "three" "four" "five" "six" + "seven" "eight" "nine" "ten" "eleven" "twelve") + string 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) + diff --git a/benchmarks/gabriel/tak.sch b/benchmarks/gabriel/tak.sch new file mode 100644 index 00000000..a795edce --- /dev/null +++ b/benchmarks/gabriel/tak.sch @@ -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))))))) diff --git a/benchmarks/gabriel/takl.sch b/benchmarks/gabriel/takl.sch new file mode 100644 index 00000000..79df0c0a --- /dev/null +++ b/benchmarks/gabriel/takl.sch @@ -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))) diff --git a/benchmarks/gabriel/takr.sch b/benchmarks/gabriel/takr.sch new file mode 100644 index 00000000..ef46d387 --- /dev/null +++ b/benchmarks/gabriel/takr.sch @@ -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))))))) diff --git a/benchmarks/gabriel/takr2.sch b/benchmarks/gabriel/takr2.sch new file mode 100644 index 00000000..c6deb8dc --- /dev/null +++ b/benchmarks/gabriel/takr2.sch @@ -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))))))) diff --git a/benchmarks/gabriel/triangle.sch b/benchmarks/gabriel/triangle.sch new file mode 100644 index 00000000..baeddd27 --- /dev/null +++ b/benchmarks/gabriel/triangle.sch @@ -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))))))