codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
; mastermind setter (define (range . args) (case (length args) ((1) (range 0 (car args) (if (negative? (car args)) -1 1))) ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1))) ((3) (let ((le? (if (negative? (caddr args)) >= <=))) (let loop ((x(car args)) (xs '())) (if (le? (cadr args) x) (reverse xs) (loop (+ x (caddr args)) (cons x xs)))))) (else (error 'range "unrecognized arguments")))) (define (fold-right op base xs) (if (null? xs) base (op (car xs) (fold-right op base (cdr xs))))) (define (make-list n x) (let loop ((n n) (xs '())) (if (zero? n) xs (loop (- n 1) (cons x xs))))) (define (sum xs) (apply + xs)) (define (uniq-c eql? xs) (if (null? xs) xs (let loop ((xs (cdr xs)) (prev (car xs)) (k 1) (result '())) (cond ((null? xs) (reverse (cons (cons prev k) result))) ((eql? (car xs) prev) (loop (cdr xs) prev (+ k 1) result)) (else (loop (cdr xs) (car xs) 1 (cons (cons prev k) result))))))) (define (cross . xss) (define (f xs yss) (define (g x zss) (define (h ys uss) (cons (cons x ys) uss)) (fold-right h zss yss)) (fold-right g '() xs)) (fold-right f (list '()) xss)) (define num-colors 6) (define num-pegs 4) (define probes (apply cross (make-list num-pegs (range 1 (+ num-colors 1))))) (define (black code probe) (define (f x y) (if (= x y) 1 0)) (sum (map f code probe))) (define (b+w code probe) (define (count x xs) (define (f y) (if (= x y) 1 0)) (sum (map f xs))) (define (f x) (min (count x code) (count x probe))) (sum (map f (range 1 (+ num-colors 1))))) (define (score code probe) (let* ((black (black code probe)) (white (- (b+w code probe) black))) (string-append (make-string black #\B) (make-string white #\W) (make-string (- num-pegs black white) #\.)))) (define (fortune xs) (let loop ((n 1) (x #f) (xs xs)) (cond ((null? xs) x) ((< (rand) (/ n)) (loop (+ n 1) (car xs) (cdr xs))) (else (loop (+ n 1) x (cdr xs)))))) (define (setter . args) (let ((code (if (pair? args) (car args) (fortune probes)))) (display "Enter your guess as a list: ") (let loop ((probe (read))) (let ((s (score code probe))) (if (string=? (make-string num-pegs #\B) s) (begin (display "You win!") (newline)) (begin (display s) (newline) (display "Try again: ") (loop (read))))))))
Private
[
?
]
Run code
Submit