game-of-life-test.scm

(define (join . xs) (string-join (map x->string xs) ""))
(define (assertion->string actual-expr matcher-expr expected-expr)
  (join actual-expr " " matcher-expr " " expected-expr))

(define-macro (assert actual-expr matcher-expr expected-expr)
  (display (assertion->string actual-expr matcher-expr expected-expr))
  (newline)
  (let* ((env (interaction-environment))
	 (a (eval actual-expr env))
	 (e (eval expected-expr env))
	 (m (eval matcher-expr env))
	 (matched (eval (m a e) env))
	 (result (if matched 'OK 'FAIL)))
    (display (join "   ... " (if matched
		 result
		 (join "expected: " e " , but: was " a))))
    (newline)
    (symbol->string result)))

(define-macro (todo actual-expr matcher-expr expected-expr)
  (let ((result 'TODO))
    (display (assertion->string actual-expr matcher-expr expected-expr))
    (newline)
    (display (join "   ... " result))
    (newline)
    (symbol->string result)))

(define (report results) (hash-table-map
		(fold (^(item ht) (begin
				    (hash-table-update! ht (string->symbol item) (cut + 1 <>) 0)
				    ht))
		      (make-hash-table 'eq?)
		      results)
		cons))
(define (state report) (let1 x (assq 'FAIL report)
		    (if (or (not x) (= (cdr x) 0)) 'OK 'FAIL)))

(load "./game-of-life.scm")

(define (assert env)
  (^(assertion)
    (let* ((actual (car assertion))
	   (matcher (cadr assertion))
	   (expected (caddr assertion))
	   (a (eval actual env))
	   (m (eval matcher env))
	   (e (eval expected env))
	   (matched (eval (m a e) env))
	   (result (if matched 'OK 'FAIL))
	   (message (if matched "" (join "expected: " e " , but: was " a))))
      (list actual matcher expected result message))))
(define (make-condition env)
   (^ (condition)
      (let* ((var (car condition))
	     (expr (cadr condition))
	     (def `(define ,var ,expr)))
	(eval def env)
	def)))
(define-macro (quand conditions . assertions)
  `(let1 env (make-module #f)
	 (let ((defs (map (make-condition env) ',conditions))
	       (results (map (assert env) ',assertions)))
	   `(,defs ,results))))

(define assertion-results cdr)
(define ok-or-fail cadr)
(let1 suite
      (quand ((x 1)
	      (y (+ 1 2)))
	     ((+ x y) = 3)
	     ((* x y) = 3))
      (print suite)
      (print (assertion-results suite))
      (print (map ok-or-fail (assertion-results suite))))

(exit)


(let* ((results
	(list

	 (assert (board-width (s-expr->board '((1 1 0) (1 0 0) (0 0 0))))
		 = 3)
	 (assert (board-height (s-expr->board '((1 1 0) (1 0 0) (0 0 0))))
		 = 3)
	 (assert (board-alive-cells (s-expr->board '((1 1 0) (1 0 0) (0 0 0))))
		 equal? '((3 3) (2 3) (3 2)))

	 (assert (board->s-expr (s-expr->board '((1 1 0) (1 0 0) (0 0 0))))
		 equal? '((1 1 0) (1 0 0) (0 0 0)))

	 (assert
	  (board->s-expr (next-board
			  (s-expr->board '((1 1 0) (1 0 0) (0 0 0)))))
	  equal? '((1 1 0) (1 1 0) (0 0 0)))
	 (assert
	  (board->s-expr (next-board
			  (s-expr->board '((1 1 0) (0 1 0) (0 0 0)))))
	  equal? '((1 1 0) (1 1 0) (0 0 0)))
	 (assert
	  (board->s-expr (next-board
			  (s-expr->board '((0 0 0) (0 1 1) (0 0 0)))))
	  equal? '((0 0 0) (0 0 0) (0 0 0)))
	 (assert
	  (board->s-expr (next-board
			  (s-expr->board '((1 1 1) (1 1 0) (0 0 0)))))
	  equal? '((1 0 1) (1 0 1) (0 0 0)))

	 ))

       (rep (report results))
       (st (state rep)))
      (print rep)
      (print st))

game-of-life.scm

(use srfi-1)

(define (list-contains? item list)
  (cond ((null? list) #f)
	((equal? item (car list)) #t)
	(else (list-contains? item (cdr list)))))
(define (cell-status w h alive-cells)
  (let1 cell (list w h)
	(if (cell-alive? cell alive-cells)
	    '1
	    '0)))

(define (s-expr->board expr)
    (if (null? expr)
	(make-board 0 0 '())
	(let* ((height (length expr))
	       (width (length (car expr)))
	       (cells (all-cells width height))
	       (alives (filter
			(^(cell)
			  (= 1 (list-ref (list-ref expr (- width (cadr cell)))
					 (- height (car cell)))))
			cells)))
	  (make-board width height alives))))

(define (make-board width height alive-cells)
  (list width height alive-cells))
(define (board->s-expr board)
  (define (make-rows width height alive-cells)
    (define (make-row width height)
      (if (= width 0)
	  '()
	  (cons (cell-status width height alive-cells) (make-row (- width 1) height))))
    (if (= height 0)
	'()
	(cons (make-row width height) (make-rows width (- height 1) alive-cells))))
  (let ((width (board-width board))
	(height (board-height board))
	(alive-cells (board-alive-cells board)))
    (make-rows width height alive-cells)))

(define (board-width board)
  (car board))
(define (board-height board)
  (cadr board))
(define (board-alive-cells board)
  (caddr board))

(define (all-cells width height)
  (define (row-cells width)
    (if (= width 0) '()
	(cons (list width height) (row-cells (- width 1)))))
  (if (= height 0) '()
      (append (row-cells width) (all-cells width (- height 1)))))
(define cell-alive? member)
(define (neighber-cells cell)
  (let ((x (car cell))
	(y (cadr cell)))
    (list
     (list (- x 1) (- y 1))
     (list (- x 1) (- y 0))
     (list (- x 1) (+ y 1))
     (list (- x 0) (- y 1))
     (list (- x 0) (+ y 1))
     (list (+ x 1) (- y 1))
     (list (+ x 1) (- y 0))
     (list (+ x 1) (+ y 1)))))
(define (next-board board)
  (let* ((cells (all-cells (board-width board) (board-height board)))
	 (alive-cells (board-alive-cells board))
	 (next-alive? (^(cell)
			(let* ((alive-neighber-number
			      (length (filter (^(c) (cell-alive? c alive-cells))
					      (neighber-cells cell))))
			      (alive (cell-alive? cell alive-cells)))
			      (cond ((and alive 
					  (or (= alive-neighber-number 2)
					      (= alive-neighber-number 3))) #t)
				    ((and (not alive)
					  (= alive-neighber-number 3)) #t)
				    (else #f)))))
	 (next-alive-cells (filter next-alive? cells)))
    (make-board (board-width board) (board-height board) next-alive-cells)))

gistfile1.txt

(+ 1 1) is 2...ok
(+ 1 2) is 4...expected: 4 , but: was 3
(* 2 2) is (+ 2 2)...ok
(* 2 2) === (+ 2 2)...ok
(* 2 2) > (+ 2 3)...expected: 5 , but: was 4
(+ x y) is 4...expected: 4 , but: was 3
(+ hoge fuga) is 'foo...TODO

hello.scm

(define (join . xs) (string-join (map x->string xs) ""))
(define (assertion->string actual-expr matcher-expr expected-expr)
  (join actual-expr " " matcher-expr " " expected-expr))

(define-macro (assert actual-expr matcher-expr expected-expr)
  (display (assertion->string actual-expr matcher-expr expected-expr))
  (newline)
  (let* ((env (interaction-environment))
	 (a (eval actual-expr env))
	 (e (eval expected-expr env))
	 (m (eval matcher-expr env))
	 (matched (eval (m a e) env))
	 (result (if matched 'OK 'FAIL)))
    (display (join "   ... " (if matched
		 result
		 (join "expected: " e " , but: was " a))))
    (newline)
    (symbol->string result)))

(define-macro (todo actual-expr matcher-expr expected-expr)
  (let ((result 'TODO))
    (display (assertion->string actual-expr matcher-expr expected-expr))
    (newline)
    (display (join "   ... " result))
    (newline)
    (symbol->string result)))

(define is eq?)
(define === is)

(define x 1)
(define y 2)

(define results (list
 (assert (+ 1 1) is 2)
 (assert (+ 1 2) is 4)
 (assert (* 2 2) is (+ 2 2))
 (assert (* 2 2) === (+ 2 2))
 (assert (* 2 2) > (+ 2 3))

 (assert (+ x y) is 4)

 (todo (+ hoge fuga) is 'foo)))

(define report (hash-table-map
		(fold (^(item ht) (begin
				    (hash-table-update! ht (string->symbol item) (cut + 1 <>) 0)
				    ht))
		      (make-hash-table 'eq?)
		      results)
		cons))
(print report)
(define state (let1 x (assq 'FAIL report)
		    (if (or (not x) (= (cdr x) 0)) 'OK 'FAIL)))
(print state)

Makefile

all: test

test:
	env gosh game-of-life-test.scm