Archive for December, 2006

One of the problems given to solve in HTDP was to write a program that solved the 8 queens problem, that is, to place 8 queens on a standard chess board so that none of them are attacking each other. I quite enjoyed working through this, and came up with something that used a straight size 64 scheme vector to represent the board which I thought would be reasonably efficient.

First of all, as encouraged by HTDP, there were the functions to manipulate and display the board:

(define-struct board (squares size))

(define (display-board b) …)

(define (coord->index x y n) …)
(define (board-ref b x y) …)

;; Constructors
(define (build-board n f) …)
(define (empty-board n) …)

and then the methods suggested within the book to solve the problem.

I’ve attached the code at the end along with fairly naive translations into Ocaml and C++.

The surprising thing to me though is that vast differences in speed. The Ocaml runs around 15 times faster than the scheme, and the C++ runs around 20 times faster than the Ocaml. Now, to some people, this might suggest that C++ is much faster than Ocaml which in turn is much faster than PLT Scheme. However, the wealth of information around on the net leads me to believe that this is not true. I therefore conclude that I am not very good at writing efficient scheme or efficient Ocaml.

I can see that there are minor algorithmic differences between the code. In particular, the C++ uses out-of-bound data rather than a Some / None type as in the Ocaml. Additionally, the C++ uses simple machine integers to represent the square types. It is difficult to believe that this accounts for the difference though, in which case, what am I doing wrong?

$ time mzscheme -qu queens.ss
cpu time: 1235 real time: 1281 gc time: 453
51886 recursive calls to (placements …)
mzscheme -qu queens.ss 0.00s user 0.00s system 0% cpu 1.468 total

$ ocamlopt -noassert -unsafe -ccopt -O3 -ccopt -fomit-frame-pointer q.ml -o q.exe
$ time ./q.exe
./q.exe 0.00s user 0.00s system 0% cpu 1.000 total

$ time ./a.exe 8 1000 | grep -v Qu
./a.exe 8 1000 0.00s user 0.00s system 0% cpu 4.938 total

mzscheme code

(module queens mzscheme

  (require (lib "42.ss" "srfi"))

  (define-struct board (squares size))

  ;; 28.2.1

  (define (display-board b)
    (printf "~n")
    (let ((s (board-squares b))
          (n (board-size b)))
      (do-ec (: y n)
             (: x n)
               (display (if (= x 0) "(" " "))
               (display (vector-ref s (coord->index x y n)))
               (when (= x 7) (printf ")~n"))))))

  ;; 28.2.2

  (define (coord->index x y n) (+ (* y n) x))

  (define (board-ref b x y)
    (vector-ref (board-squares b) (coord->index x y (board-size b))))

  (define (build-board n f)
    (let ((size (* n n)))
       (vector-of-length-ec size
                            (:range i size)
                            (f (remainder i n) (quotient i n)))

  (define (empty-board n)
    (build-board n (lambda (x y) #f)))

  ;; 28.2.3

  (define-struct posn (x y))

  (define (threatened? queen square)
    (let ((x1 (posn-x queen))
          (y1 (posn-y queen))
          (x2 (posn-x square))
          (y2 (posn-y square)))
      (or (= x1 x2)
          (= y1 y2)
          (= (- x2 x1) (- y2 y1))
          (= (- x1 y2) (- x2 y1)))))

  ;; 28.2.4

  (define init-pos (make-posn 0 0))

  (define (add-queen board p)
    (let ((s (board-size board))
          (qx (posn-x p))
          (qy (posn-y p)))
      (build-board s (lambda (x y)
                       (let ((c (board-ref board x y)))
                         (cond ((and (= x qx) (= y qy)) 'Qu)
                               (c c)
                               ((threatened? p (make-posn x y)) 'At)
                               (else #f)))))))

  (define (invalid-posn? board p)
    (not (eq? (board-ref board (posn-x p) (posn-y p)) #f)))

  (define (next-valid-posn board p)
    (let ((s (board-size board)))
      (let loop ((x (+ 1 (posn-x p)))
                 (y (posn-y p)))
        (cond ((>= x s) (loop 0 (+ y 1)))
              ((>= y s) #f)
              (else (let ((new-p (make-posn x y)))
                      (if (invalid-posn? board new-p)
                          (loop (+ x 1) y)

  (define (display-posn p)
    (if (posn? p)
        (printf "(~a, ~a)~n" (posn-x p) (posn-y p))
        (printf "Not posn~n")))

  (define *count-placements* 0)

  (define (placement board p rem)
    (set! *count-placements* (+ *count-placements* 1))
    (cond ((= rem 0) board)
          ((not p) #f)
          ((invalid-posn? board p) (placement board (next-valid-posn board p) rem))
          (else (let loop ((cur-pos p))
                  (if (not cur-pos) #f
                      (let ((possible-board (placement (add-queen board cur-pos) init-pos (- rem 1))))
                        (if possible-board possible-board
                            (loop (next-valid-posn board cur-pos)))))))))

  (define (solve-for-queens n)
    (set! *count-placements* 0)
    (time (display-board (placement (empty-board n) init-pos n)))
    (printf "~a recursive calls to (placements ...)~n"

  (solve-for-queens 8 )

  (provide (all-defined)))

;; (require "queens.ss")

Ocaml code

type square = Queen | Safe | Attacked;;
type posn = Posn of int * int;;
type board = Board of square array * int;;

let string_of_square = function
  | Queen -> "Qu"
  | Safe -> "#f"
  | Attacked -> "At";;

let index_of_coord x y n = (y*n) + x;;

let coord_of_index i n =
  let y = i / n in (i - y*n, y);;

let board_ref b x y =
  match b with
      Board (squares, size) -> Array.get squares (index_of_coord x y size);;

let print_board board =
  match board with
      None -> print_string "Nonen"
    | Some (Board (_, s) as b) ->
	let b_x = (s - 1) in
	let rec loop x y =
	  if y >= s then ()
	  else if x >= s then loop 0 (y+1)
	  else begin
	    print_string (if x = 0 then "(" else " ");
	    let i = index_of_coord x y s in
	      print_string (string_of_square (board_ref b x y));
	      if x = b_x then print_string ")n";
	      loop (x+1) y
	in loop 0 0;;

let build_board n f =
  Board (Array.init (n * n) f, n);;

let empty_board n =
  build_board n (fun i -> Safe);;

let is_threatened queen square =
  match queen, square with
      (x1, y1), (x2, y2) ->
	x1 == x2 ||
	  y1 == y2 ||
	  (x2 - x1) == (y2 - y1) ||
	  (x1 - y2) == (x2 - y1);;

let add_queen board p =
  match board, p with
      Board (squares, size), (qx, qy)
	-> build_board size (fun i ->
			       let c, qi = (Array.get squares i), index_of_coord qx qy size in
				 if i == qi then Queen
				 else if c != Safe then c
				 else if (is_threatened p (coord_of_index i size)) then Attacked
				 else Safe);;

let is_invalid_posn board p =
  match p with
      None -> true
    | Some (Posn (x, y) as posn) -> board_ref board x y != Safe;;

let next_valid_posn board p =
  match board, p with
      _, None -> None
    | Board (_, size), Some (Posn (x, y)) ->
	let rec loop x y =
	  if x >= size then loop 0 (y+1)
	  else if y >= size then None
	  else let new_posn = Posn (x, y) in
	    if is_invalid_posn board (Some new_posn) then loop (x+1) y
	    else Some new_posn
	in loop (x+1) y;;

let valid_board b =
  match b with
      Some (Board (_, _)) -> true
    | _ -> false;;

let init_pos = Some (Posn (0,0));;

let rec placement board posn rem =
  match board, posn with
      None, _ -> None
    | _, None -> None
    | Some (Board (squares, size) as b), Some (Posn (x, y) as p) ->
	if rem = 0 then board
	else if is_invalid_posn b posn then placement board (next_valid_posn b posn) rem
	else let rec loop curpos =
	  match curpos with
	      None -> None
	    | Some (Posn (x, y)) ->
		let possible_board = (placement
					(Some (add_queen b (x, y)))
					(rem - 1)) in
		  if valid_board possible_board then possible_board
		  else loop (next_valid_posn b curpos)
	in loop posn;;

let do_times f n =
  Printf.printf "n==%dn" n;
  let rec loop n =
    f ();
    if n != 1 then loop (n - 1)
  in loop n;;

let solve_queens n =
  (placement (Some (empty_board n)) init_pos n);;

do_times (fun () -> (solve_queens 8 )) 10;;

print_board (solve_queens 8 );;

C++ code

#include <vector>
#include <string>
#include <iostream>

using namespace std;

namespace Status {
    static const int Qu      = 0;
    static const int Safe    = 1;
    static const int At      = 2;
    static const int Invalid = 3;

    static string mapping[] = { "Qu", "#f", "At", "I" };
    string string_of_square(int i) { return mapping[i]; }

using namespace Status;

typedef std::vector<int> Squares;

struct Posn
    int x_;
    int y_;

    Posn(int x, int y) : x_(x), y_(y) { }
    bool is_invalid() const { return (x_ < 0) && (y_ < 0); }

const Posn init_pos(0, 0);

class Board
    Squares squares_;
    int size_;

    int index_of_coord(int x, int y) const { return y * size_ + x; }

    Board(int size) : squares_((size * size), Safe), size_(size) { }
    int ref(int x, int y) const { return squares_[index_of_coord(x, y)]; }
    int ref(const Posn& p) const { return ref(p.x_, p.y_); }

    void display() const {
        for (int y = 0; y < size_; ++y) {
            for (int x = 0; x < size_; ++x) {
                cout << ((x == 0) ? "(" : " ");
                cout << string_of_square(ref(x, y));
            cout << ")n";

    template<typename T>
    static Board build_board(int size, T f) {
        Board b(size);
        for (int y = 0; y < size; ++y) {
            for (int x = 0; x < size; ++x) {
                b.squares_[b.index_of_coord(x, y)] = f(x, y);

        return b;

    Board add_queen(const Posn& p) const;

    Posn next_valid_posn(const Posn& p) const {
        for (int y = p.y_; y < size_; y++) {
            for (int x = p.x_ + 1; x < size_; x++) {
                if (ref(x, y) == Safe) { return Posn(x, y); }

        return Posn(-1, -1);

    static Board invalid_board() {
        static Board b(1);
        b.squares_[0] = Invalid;
        return b;

    bool is_invalid() const { return squares_[0] == Invalid; }

    static Board placement(const Board& b, const Posn& p, int rem) {
        if (b.is_invalid()) { return b; }
        else if (p.is_invalid()) { return invalid_board(); }
        else if (rem == 0) { return b; }
        else if (b.ref(p) != Safe) {
            return placement(b, b.next_valid_posn(p), rem);
        } else {
            Posn curpos = p;
            while (! curpos.is_invalid()) {
                Board b1 = placement(b.add_queen(curpos), init_pos, rem - 1);

                if (b1.is_invalid()) {
                    curpos = b.next_valid_posn(curpos);
                } else {
                    return b1;
            return invalid_board();

bool is_threatened(int x1, int y1, int x2, int y2)
    return x1 == x2 ||
        y1 == y2 ||
        (x2 - x1) == (y2 - y1) ||
        (x1 - y2) == (x2 - y1);

class add_queen_fobj
    add_queen_fobj(const Board& b, const Posn& p) : b_(b), p_(p) { }

    int operator()(int x2, int y2) {
        int c = b_.ref(x2, y2);
        int x1 = p_.x_;
        int y1 = p_.y_;

        if ((x1 == x2) && (y1 == y2)) { return Qu; }
        else if (c != Safe) { return c; }
        else if (is_threatened(x1, y1, x2, y2)) { return At; }
        else { return Safe; }

    const Board& b_;
    const Posn& p_;

Board Board::add_queen(const Posn& p) const {
    return build_board(size_, add_queen_fobj(*this, p));

void usage(const char* prog)
    cout << "usage: " << prog << " [size] [times]n";

int main(int argc, char* argv[])
    if (argc != 3) { usage(argv[0]); }
    int size = atoi(argv[1]);
    int times = atoi(argv[2]);

    Board b(size);
    Board result(1);
    for (int i = 0; i < times; ++i) {
        result = Board::placement(b, init_pos, 8 );


Read Full Post »

Pattern matching in scheme

I’ve been looking for an excuse for familiarising myself with PLT scheme’s pattern matching library for a while. Finally, I came across an article about implementing a basic Computer Algebra System. The Ocaml source code can be found here. Using the pattern matching library it can be fairly mechanically translated into scheme.

(require (lib "match.ss"))

(define-struct plus (e1 e2))
(define-struct times (e1 e2))
(define-struct divide (e1 e2))

(define MP make-plus)
(define MT make-times)
(define MD make-divide)

(define simplify
   (($ times a ($ plus b c)) (MP (simplify (MT a b)) (simplify (MT a c))))
   (($ divide ($ divide a b) ($ divide c d)) (MD (simplify (MT a d))
                                                 (simplify (MT b c))))
   (e e)))

(define expr->list
   (($ times a b) (list (expr->list a) '* (expr->list b)))
   (($ plus a b) (list (expr->list a) '+ (expr->list b)))
   (($ divide a b) (list (expr->list a) '/ (expr->list b)))
   (e e)))

(define expr (make-times 'x (make-plus 'y 'z)))

(printf "orig: ~a~n" (expr->list expr))
(printf "new: ~a~n" (expr->list (simplify expr)))

(let ((e (MD (MD 'a 'b) (MD 'c 'd))))
  (printf "div: ~a -> ~a~n" (expr->list e) (expr->list (simplify e))))

If I had come across this post a few weeks ago, I probably wouldn’t have even considered the implementation using define-struct. HTDP has certainly improved the way I think about coding scheme now and indeed several of the exercises in the book involve constructing various scheme evaluators that embed a simple CAS like the one above.

The article concludes with the following quote:

“…as you can see, Ocaml’s variant types and pattern matching are a perfect fit for the problems a programmer writing a CAS would face. In fact, few other languages, with the possible exception of Haskell, would have fit this problem as well.”

It seems that with the appropriate extensions, scheme can be a good fit for this type of problem too.

Read Full Post »

Learning to program functionally

A major problem I’ve found with learning scheme in isolation is that it is quite easy to pick up the syntax and then start programming in with a heavy C++ accent. Although this demonstrates the flexibility of scheme, it is not what I’m really after. The question is, how to learn to write in a good style. I can think of a number of possibilities:

  1. Keep writing programs in scheme and hope my style will improve
  2. Read books that specifically teach good scheme style
  3. Read real world code written in scheme

I’ve been inspired to work through some of the exercises in HTDP from various posts I’ve read on Lambda the Ultimate. So far, the book advises a similar approach to designing programs as I have seen before: decide on your data structures before writing the code and define the data structures using (define-struct …). I’ve found it a useful exercise to write functions that convert the data structures into lists that could be evaluated to re-create the original data. Here is an example, more or less from chapter 17.

(define-struct expr (op a1 a2))
(define-struct f-app (name expr))
(define-struct fn (name arg body))

(define f (make-fn 'f 'x (make-expr '+ 3 'x)))
(define i (make-fn 'i 'v (make-expr '+ (make-expr '* 'v 'v) (make-expr '* 'v 'v))))

;;; Convert expressions to lists

(define (add-quote s)
  (string->symbol (string-append "'" (symbol->string s))))

(define (expr->list e)
  (cond ((expr? e) (list 'make-expr
                         (add-quote (expr-op e))
                         (expr->list (expr-a1 e))
                         (expr->list (expr-a2 e))))
        ((f-app? e) (list 'make-f-app
                          (add-quote (f-app-name e))
                          (expr->list (f-app-expr e))))
        ((symbol? e) (add-quote e))
        ((number? e) e)
        (else (raise (format "Error: invalid type ~a" e)))))

(define (fn->list f)
  (list 'make-fn
        (add-quote (fn-name f))
        (add-quote (fn-arg f))
        (expr->list (fn-body f))))

(for-each (lambda (x) (display (format "~a~%" (fn->list x))))
          (list f i))

Read Full Post »