Scheme

Hey guys,

I've been reading a lot about Scheme lately. I think I would like it a lot. I've been contemplating buying SICP but it's expensive (a hundred bucks? fuck that).

Can you give me a non-trivial program that I can try to write in Scheme? Maybe a text-based mini-game or something. If I get around to doing it I'll post it here.

;; Simple tic-tac-toe with minimax in R5RS scheme + some SRFIs

;; PLT specific syntax for the imports
#lang r5rs

(#%require
 ; (only srfi/1 any filter)
 (only srfi/27 random-integer)
 (only srfi/28 format)
 (only srfi/39 parameterize make-parameter)
 (only srfi/43 vector-every vector-map vector-copy))

; Fuck PLT's immutable lists, really
(define (any p l) (and (pair? l) (or (p (car l)) (any p (cdr l)))))
(define (filter p l) (if (null? l) l (let ((r (filter p (cdr l)))) (if (p (car l)) (cons (car l) r) r))))
;; End of imports

;; Parameters (similar to fluid variables, dynamically scoped variables)
(define board (make-parameter #f))
(define turn (make-parameter #f)) ; 1 or -1

(define other -)
(define empty-board (make-vector 9 #f))

;; Game loop
(define (play myturn)
  (parameterize ((board (vector-copy empty-board)) (turn 1))
    (let loop ()
      ;; Render
      (print-board)
      (cond
        ;; Check for of game
        ((value) => (lambda (w) (display (cond ((zero? w) "It's a tie!\n")
                                               ((= myturn w) "You won!\n")
                                               (else "You lost!\n")))))
        ;; Player turn?
        ((= (turn) myturn)
         (display "Enter square number (1-9):\n")
         (let ((num (read)))
           (if (or (not (integer? num)) (> num 9) (< num 1)
                   (vector-ref (board) (- num 1)))
               (begin
                 (display "Invalid input.\n")
                 (if (not (eof-object? num)) (loop)))
               (begin
                 (vector-set! (board) (- num 1) (turn))
                 (parameterize ((turn (other (turn))))
                   (loop))))))
        ;; Computer turn
        (else
         (parameterize ((board (minimax)) (turn (other (turn))))
           (loop)))))))

;; Return optimal new board after 1 turn
(define (minimax)
  ;; Return (cons <best board> <best result>)
  (define (maximal)
    (cond
      ;; Check for end of game
      ((value) => (lambda (v) (cons (board) (* (turn) v))))
      (else
       ;; Get the best of the possible moves by recursing
       (do ((steps (step) (cdr steps))
            (maxi (cons #f -inf.0)
                  (let* ((result (parameterize ((board (car steps))
                                                (turn (other (turn))))
                                   (maximal)))
                         ;; Only return 1 board ahead
                         (new-maxi (cons (car steps) (- (cdr result)))))
                    (if (> (cdr maxi) (cdr new-maxi))
                        maxi
                        new-maxi))))
         ((or (null? steps) (= 1 (cdr maxi))) maxi)))))
 
  (car (maximal)))

;; Return the winner (-1, 1), tie (0), or none (#f)
(define (value)
  (define lines
    '((0 1 2)
      (3 4 5)
      (6 7 8)
     
      (0 3 6)
      (1 4 7)
      (2 5 8)
     
      (0 4 8)
      (2 4 6)))
  (cond
    ;; Any of the lines occupied by 1 player?
    ((any
      (lambda (a) (and (equal? (car a) (cadr a)) (equal? (cadr a) (caddr a)) (car a)))
      (map (lambda (x) (map (lambda (y) (vector-ref (board) y)) x)) lines))
     => values)
    ;; Full?
    ((vector-every values (board)) 0)
   
    (else #f)))

;; Simple fisher-yates
(define (vector-shuffle! v)
  (do ((n (vector-length v) (- n 1)))
    ((zero? n) v)
    (let ((a (random-integer n))
          (b (- n 1)))
      (if (not (= a b))
          (let ((t (vector-ref v a)))
            (vector-set! v a (vector-ref v b))
            (vector-set! v b t))))))

;; Return a shuffled list of possible next boards
(define (step)
  (filter
   values
   (vector->list
    (vector-shuffle!
     (vector-map
      (lambda (i x)
        (and (not x)
             (let ((temp (vector-copy (board))))
               (vector-set! temp i (turn))
               temp)))
      (board))))))

(define (print-board)
  (display
   (apply
    format "~a|~a|~a~%-----~%~a|~a|~a~%-----~%~a|~a|~a~%~%"
    (map
     (lambda (x) (case x ((1) #\X) ((-1) #\O) ((#f) #\ )))
     (vector->list (board))))))

;; Let's go
(display "Do you want to go first? (#f/#t)\n")
(let ((first (read)))
  (play (if first 1 -1)))