169 lines
4.8 KiB
Scheme
169 lines
4.8 KiB
Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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 511)
|
|
(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)))
|
|
(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)) #f)
|
|
(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)
|
|
" at "
|
|
(number->string y)
|
|
".")))
|
|
|
|
(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.")))
|
|
(else (begin (newline) (display "Failure."))))))
|
|
|
|
;;; call: (start)
|
|
|
|
(start)
|
|
(newline)
|
|
|