TeamSPoon/8queens.html

## 8queens.html
<!DOCTYPE html>
<html>
<head>
<script type="text/javascript">
function makeContext() { return { choices:[], trail:[], halted:false }; }

// Push a new choice point onto the stack
function pushChoice( ctx, choiceThunk ) {
    ctx.choices.unshift( { thunk:choiceThunk, trailIndex:ctx.trail.length } );
}

// Change the choice point on the top of the stack
function setChoice( ctx, choiceThunk ) {
    ctx.choices[0].thunk = choice-thunk;
}

// Pop the top choice point and return it
function popChoice( ctx ) {
    if( ctx.choices.length > 0 ) {
        return ctx.choices.shift();
    }

    return false;
}

// Whether there are any choice-points
function hasChoices( ctx ) {
    return (ctx.choices.length > 0);
}

// Back-track to next available choice
function backtrack( ctx ) {
    //console.log( "backtrack " + ctx );

    if( ctx.choices.length > 0 ) {
        var choice = ctx.choices[0];
        undoBindings( ctx.trail, choice.trailIndex );
        return choice.thunk;
    }
    return false;
}

// Make a variable
function Variable() {}
Variable.prototype.value = false;
Variable.prototype.valueOf = function() { return this.value; }
Variable.prototype.toString = function() { return this.value ? "{" + this.value + "}" : "VAR"; }
function isVariable( v ) {
    return ( typeof v === "object"
             && v.constructor === Variable );
}

//Structs
function Struct(name,args) {
    this.name = name;
    this.args = args;
}
Struct.prototype.toString = function() { return this.name + "(" + this.args.toString() + ")"; }
function isStruct( v ) {
    return ( typeof v === "object"
             && v.constructor === Struct );
}

// Pairs
function Pair( car, cdr ) {
    this.car = car;
    this.cdr = cdr;
}
Pair.prototype.toString = function() { return "pair<" + this.car + "," + this.cdr + ">"; }
function isPair( v ) {
    return ( v && v.constructor === Pair );
}
var Empty = { toString:function(){ return "Empty"; }} ; //empty list

// Undo variable bindings from the given index
function undoBindings( trail, index ) {
    var trailSize = trail.length;

    for( var i = index; i < trailSize; i++ ) {
        delete trail[i].value;
    }

    trail.length = index;
}

function trampoline( fn ) {
    while( fn ) {
        fn = fn();
        //console.log( "fn=" + fn );
    }

    //console.log( "trampoline exiting" );
}

// Chase Variable contents until non-var or unbound
function dereferenceTerm( maybeVar ) {
    while( isVariable( maybeVar ) ) {
        var value = maybeVar.value;
        if( value ) maybeVar = value;
        else break;
    }

    return maybeVar;
}

// Unify two terms
// If unification succeeds return true.
// If unification fails then undo all bindings back to the initial index and return false.
function unify( ctx, a, b ) {
    var baseIndex = ctx.trail.length;
    if( unifyTrail( ctx.trail, a, b ) ) return true;
    undoBindings( ctx.trail, baseIndex );
    return false;
}

// Unify two terms and push new bindings on to the trail.
function unifyTrail( trail, a, b ) {
    if( a == b ) return true; //takes care of numbers, atoms and strings

    //lists and improper lists
    if( isPair(a) && isPair(b) ) {
        if( unifyTrail( trail, a.car, b.car )) return unifyTrail( trail, a.cdr, b.cdr );
        return false;
    }

    //structs
    if( isStruct(a) && isStruct(b)
        && a.name == b.name
        && a.args.length == b.args.length ) {
        for( var i = 0; i < a.args.length; i++ ) {
            if( ! unifyTrail( trail, a.args[i], B.args[i] )) return false;
        }
        return true;
    }

    //variables
    if( isVariable(a) || isVariable(b) ) {
        a = dereferenceTerm(a);
        b = dereferenceTerm(b);
        var ref;
        var other;

        if( isVariable(a) ) {
            ref = a;
            other = b;
        }
        else if( isVariable(b) ) {
            ref = b;
            other = a;
        }
        else {
            return unifyTrail( trail, a, b );
        }

        //make variable binding
        ref.value = other;
        trail.push( ref );
        return true;
    }

    return false;
}

function arrayToList( ary ) {
    var list = Empty;
    for( var i = ary.length - 1; i >= 0; i-- ) {
        list = new Pair( ary[i], list );
    }

    return list;
}

function listToArray( list ) {
    list = dereferenceTerm(list);
    var ary = [];
    while( isPair(list) ) {
        ary.push( dereferenceTerm(list.car) );
        list = dereferenceTerm(list.cdr);
    }
    return ary;
}

function test() {
    var start = Date.now();
    var solns = 0;

    for( var i = 0; i < 10; i++ ) {
        solns = 0;
        run_queens( function(a) { solns++; } );
    }

    var end = Date.now();

    var log = document.getElementById( "log" );
    log.innerHTML += "Time  = " + ((end-start)/10) + "<br />";
    log.innerHTML +=  "Count = " + solns + "<br />";
}

function clear() {
    var log = document.getElementById( "log" );
    log.innerHTML = "";
}

function solutions() {
    var log = document.getElementById( "log" );
    log.innerHTML = "";
    run_queens( function(a) { log.innerHTML += listToArray(a) + "<br />"; } );
}

function run_queens( callback ) {
    var ctx = makeContext();
    var A = new Variable();
    trampoline( function() {
        return board_1( ctx, function() {
            return queens_1( ctx, function() {
                callback(A);
                return backtrack( ctx );
            }, A );
        }, A );
    });
}

function board_1( ctx, cont, A ) {
    if( unify( ctx, arrayToList([
        new Struct( "/", [1, new Variable()] ),
        new Struct( "/", [2, new Variable()] ),
        new Struct( "/", [3, new Variable()] ),
        new Struct( "/", [4, new Variable()] ),
        new Struct( "/", [5, new Variable()] ),
        new Struct( "/", [6, new Variable()] ),
        new Struct( "/", [7, new Variable()] ),
        new Struct( "/", [8, new Variable()] )
    ]), A )) {
        return cont;
    }

    return backtrack(ctx);
}

function queens_1( ctx, cont, A ) {
    A = dereferenceTerm(A);
    pushChoice( ctx, function() {
        popChoice( ctx ); //no more clauses
        var Row, Col, Rest;
        var success;

        if( isVariable(A) ) {
            Row  = new Variable();
            Col  = new Variable();
            Rest = new Variable();
            unify( ctx, new Pair( new Struct("/",[Row,Col]), Rest), A );
            success = true;
        }
        else if( isPair(A) && isStruct(A.car)
                 && A.car.name == "/" && A.car.args.length == 2 ) {

            Row  = dereferenceTerm(A.car.args[0]);
            Col  = dereferenceTerm(A.car.args[1]);
            Rest = dereferenceTerm(A.cdr);
            success = true;
        }
        else success = false;

        if( success ) {
            return function() {
                return queens_1( ctx, function() {
                    return member_2( ctx, function() {
                        return safe_2( ctx, cont, new Struct("/",[Row,Col]), Rest );
                    }, Col, arrayToList([1,2,3,4,5,6,7,8]));
                }, Rest );
            }
        }

        return backtrack( ctx );
    });

    if( A === Empty ) return cont;
    return backtrack( ctx );
}

function safe_2( ctx, cont, A, B ) {
    A = dereferenceTerm(A);
    B = dereferenceTerm(B);
    pushChoice( ctx, function() {
        popChoice( ctx ); //no more clauses
        var Row, Col, Row1, Col1, Rest;
        var success;

        if( isVariable(A) ) {
            Row = new Variable();
            Col = new Variable();
            unify( ctx, new Struct("/",[Row,Col]), A );
            success = true;
        }
        else if( isStruct(A) && A.name == "/" && A.args.length == 2 ) {
            Row = dereferenceTerm(A.args[0]);
            Col = dereferenceTerm(A.args[1]);
            success = true;
        }
        else success = false;

        if( success ) {
            if( isVariable(B) ) {
                Row1 = new Variable();
                Col1 = new Variable();
                Rest = new Variable();
                unify( ctx, new Pair( new Struct("/",[Row1,Col1]), Rest), B );
                success = true;
            }
            else if( isPair(B) && isStruct(B.car)
                     && B.car.name == "/" && B.car.args.length == 2 ) {

                Row1 = dereferenceTerm(B.car.args[0]);
                Col1 = dereferenceTerm(B.car.args[1]);
                Rest = dereferenceTerm(B.cdr);
                success = true;
            }
            else success = false;
        }

        if( success
           && Col != Col1
           && (Col1 - Col) != (Row1 - Row)
           && (Col1 - Col) != (Row - Row1)) {

            return function() { return safe_2( ctx, cont, new Struct("/", [Row, Col] ) , Rest ); }
        }

        return backtrack( ctx );
    });

    if( B === Empty ) return cont;
    return backtrack( ctx );
}

function member_2( ctx, cont, A, B ) {
    //console.log( "member_2 " + A.toString() + " " + B.toString() );

    A = dereferenceTerm(A);
    B = dereferenceTerm(B);
    pushChoice( ctx, function() {
        //console.log( "member_2.2 " + A.toString() + " " + B.toString() );
        popChoice( ctx ); //no more clauses
        var Tail;
        var success;
        if( isVariable(B) ) {
            Tail = new Variable();
            unify( ctx, new Pair( new Variable(), Tail ), B );
            success = true;
        }
        else if( isPair(B) ) {
            Tail = dereferenceTerm( B.cdr );
            success = true;
        }
        else success = false;

        if( success ) return function() { return member_2( ctx, cont, A, Tail ); }

        return backtrack( ctx );
    });

    //console.log( "member_2.1 " + A.toString() + " " + B.toString() );
    if( isPair(B) && unify( ctx, A, B.car )) {
        //console.log( "OK " + cont );
        return cont;
    }

    return backtrack( ctx );
}

/*
var ctx = makeContext();
var A = new Variable();
trampoline( member_2( ctx,
                      function() { console.log( "A=" + A.value ); return backtrack( ctx ); },
                      A,
                      arrayToList([1,2,3,4,5,6,7,8]) ));
*/

</script>
</head>
<body>
<a href="javascript:test()">Test</a> |
<a href="javascript:solutions()">Solutions</a> |
<a href="javascript:clear()">Clear</a>
<hr />
<div id="log"></log>

</body>
</html>

## test-queens.rkt
#lang racket

(define (make-context)
  (vector null  ; 0 choice stack
          null  ; 1 undo trail
          #f    ; 2 halted ?
          ))

;; Push a new choice point onto the stack
(define (push-choice! ctx choice-thunk)
  (vector-set! ctx 0
               (cons (vector choice-thunk         ; choice is vector since may want to add other state later
                             (vector-ref ctx 1))  ; capture the undo-trail for backtracking
                     (vector-ref ctx 0))))

;; Change the choice point on the top of the stack
(define (set-choice! ctx choice-thunk)
  (vector-set! (car (vector-ref ctx 0) 0 choice-thunk)))

;; Pop the top choice point and return it
(define (pop-choice! ctx)
  (let ([top (vector-ref ctx 0)])
    (if (not (null? top))
        (begin
          (vector-set! ctx 0 (cdr top))
          (car top))
        #f)))

;; Whether there are any choice-points
(define (has-choices? ctx) (not (null? (vector-ref ctx 0))))

;; Back-track to next available choice
(define (backtrack ctx)
  (let* ([top (vector-ref ctx 0)]
         [choice (if (not (null? top)) (car top) #f)])
    (if choice
        (let ([choice-thunk (vector-ref choice 0)]
              [trail-base   (vector-ref choice 1)])
          (undo-bindings-ctx ctx trail-base)
          (choice-thunk))
        #f)))

;; Undo variable bindings after the given one (exclusive), and update the context.
;; Assumes variables are boxes.
(define (undo-bindings-ctx ctx binding)
  (undo-bindings (vector-ref ctx 1) binding)
  (vector-set! ctx 1 binding))

;; Undo variable bindings from the head to the tail (exclusive)
(define (undo-bindings head tail)
  (unless (eq? head tail)
    (set-box! (car head) #f) ; undo binding
    (undo-bindings (cdr head) tail)))

;; Push a variable binding onto the trail
(define (push-binding ctx variable)
  (vector-set! ctx 1 (cons variable (vector-ref ctx 1))))

;; Unify two terms and add to the trail - #t if success, #f otherwise
(define (unify ctx a b)
  (let* ([trail-base (vector-ref ctx 1)]
         [trail-head (unify-trail trail-base trail-base a b)])
    (if trail-head
        (begin (when (not (eq? trail-head trail-base))
                 (vector-set! ctx 1 trail-head))
               #t)
        #f)))

;; Create a new variable
(define (new-variable) (box #f))

;; Unify two terms and cons new bindings onto the trail-head.
;; If unification succeeds return the new trail-head.
;; If unification fails then undo all bindings back to the trail-base (exclusive)
;; and return #f.
(define (unify-trail trail-head trail-base a b)
  ;(printf "unify-trail ~a ~a\n" a b)

  (cond
    [(eqv? a b) trail-head] ; takes care of symbols (atoms), numbers and identical objects
    [(and (string? a) (string? b) (equal? a b)) trail-head]

    ; lists and improper lists
    [(and (pair? a) (pair? b))
     (let ([car-unification (unify-trail trail-head trail-base (car a) (car b))])
       (if car-unification
           (unify-trail car-unification trail-base (cdr a) (cdr b))
           #f))]

    ; variables
    [(or (box? a) (box? b))
     (let ([deref-a (dereference-term a)]
           [deref-b (dereference-term b)])
       ; Determine primary reference and value to unify with it
       (let-values ([(ref other) (cond
                                   [(box? deref-a) (values deref-a deref-b)]
                                   [(box? deref-b) (values deref-b deref-a)]
                                   [else (values #f #f)])])
         (if ref
             ; make variable binding and add to trail
             (begin
               (set-box! ref other)
               (cons ref trail-head))
             ; neither is a ref (after dereferencing) - unify
             (unify-trail trail-head trail-base deref-a deref-b))))]

    [else
   ;  (printf "unify-fail\n")
     (undo-bindings trail-head trail-base) #f]))

;(define-syntax

;; Chase box contents until non-box or empty box
(define (dereference-term maybe-box)
  (if (box? maybe-box)
      (let ([value (unbox maybe-box)])
        (if value
            (dereference-term value)
            maybe-box))
      maybe-box))


;; Backtrack through all solutions of the given query.
;; The query is a proc of the form λ(ctx continue).
(define (all-solutions query)
  (let ([ctx (make-context)])
    (query ctx (thunk (backtrack ctx)))))

(define-syntax with-vars
  (syntax-rules ()
    [(_ (var-name ... ) body ...)
     (let ([var-name (new-variable)]
           ...)
       body ...)]))

(define-syntax init-vars
  (syntax-rules ()
    [(_ (var-name ... ) body ...)
     (begin (set! var-name (new-variable))
            ...
            body ...)]))

(define (test)
  (let ([start (current-inexact-milliseconds)]
        [solns null]
        [ctx (make-context)])
    (let loop ([iteration 1])
      (set! solns null)
      (with-vars
       (A)
       (board/1 ctx
                (thunk (queens/1
                        ctx
                        (thunk (set! solns (cons (dereference-term A) solns))
                               (backtrack ctx))
                        A))
                A))
      (when (< iteration 1000) (loop (+ iteration 1))))
    (printf "Time = ~a\n" (/ (- (current-inexact-milliseconds) start) 1000))
    (printf "Count: ~a\n" (length solns))
    ))


(define (run_queens/1 ctx continue)
  (with-vars
   (A)
   (board/1 ctx
            (thunk (queens/1
                    ctx
                    (thunk (printf "hello ~a\n" A)
                           (continue))
                    A))
            A)))

(define (board/1 ctx continue A)
  (with-vars
   (C1 C2 C3 C4 C5 C6 C7 C8)
   (if (unify ctx (list (list '/ 1 C1)
                        (list '/ 2 C2)
                        (list '/ 3 C3)
                        (list '/ 4 C4)
                        (list '/ 5 C5)
                        (list '/ 6 C6)
                        (list '/ 7 C7)
                        (list '/ 8 C8))
              A)
       (continue)
       (backtrack ctx))))

(define (queens/1 ctx continue A)
  (set! A (dereference-term A))
  (push-choice!
   ctx
   (thunk (pop-choice! ctx)
          (let ([Row #f][Col #f][Rest #f])
            (if (match A
                  [(box _)
                   (init-vars (Row Col Rest) (unify ctx (cons (list '/ Row Col) Rest) A))]
                  [(cons (list '/ @Row @Col) @Rest)
                   (set! Row  (dereference-term @Row))
                   (set! Col  (dereference-term @Col))
                   (set! Rest (dereference-term @Rest))]
                  [_ #f])
                (queens/1 ctx
                          (thunk
                           (member/2 ctx
                                     (thunk
                                      (safe/2 ctx continue (list '/ Row Col) Rest))
                                     Col '(1 2 3 4 5 6 7 8)))
                          Rest)

                (backtrack ctx)))))

  (if (null? A)
      (continue)
      (backtrack ctx)))

(define (safe/2 ctx continue A B)
  (set! A (dereference-term A))
  (set! B (dereference-term B))
  (push-choice!
   ctx
   (thunk (pop-choice! ctx)
          (let ([Row #f][Col  #f][Row1  #f][Col1  #f][Rest #f])
            (if (and (match A
                       [(box _) (init-vars (Row Col) (unify ctx (list '/ Row Col) A))]
                       [(list '/ @Row @Col)
                        (set! Row (dereference-term @Row))
                        (set! Col (dereference-term @Col))]
                       [_ #f])

                     (match B
                       [(box _) (init-vars (Row1 Col1 Rest)
                                           (unify ctx (cons (list '/ Row1 Col1) Rest) B))]
                       [(cons (list '/ @Row @Col) @Rest)
                        (set! Row1 (dereference-term @Row))
                        (set! Col1 (dereference-term @Col))
                        (set! Rest (dereference-term @Rest))]
                       [_ #f])

                     (not (=  Col Col1))
                     (not (= (- Col1 Col) (- Row1 Row)))
                     (not (= (- Col1 Col) (- Row Row1))))
                (safe/2 ctx continue (list '/ Row Col) Rest)
                (backtrack ctx)))))

  (if (null? B)
      (continue)
      (backtrack ctx)))

(define (member/2 ctx continue A B)
  (set! A (dereference-term A))
  (set! B (dereference-term B))
  (push-choice!
   ctx
   ;; member(X, [Head | Tail]) :- member(X, Tail).
   (thunk (pop-choice! ctx) ; no more clauses
          (let ([Tail #f])
            (if (match B
                  [(box _) (init-vars (Tail) (unify ctx (cons (new-variable) Tail) B))]
                  [(cons _ @Tail) (set! Tail (dereference-term @Tail))]
                  [_ #f])

                (member/2 ctx continue A Tail)
                (backtrack ctx)))))

  ; member(X, [X | Tail]).
  ; X is alias for A
  ; Tail is never used
  (if (match B
        [(cons @X _) (unify ctx A @X)]
        [_ #f])
      (continue)
      (backtrack ctx)))

(all-solutions
 (λ(ctx continue)
   (with-vars
    (A)
    (member/2 ctx
              (thunk (printf "member: ~a\n" A)
                     (continue))
              A '(1 2 3 4 5 6 7 8)))))
	<!DOCTYPE html>
	<html>
	<head>
	<script type="text/javascript">
	function makeContext() { return { choices:[], trail:[], halted:false }; }

	// Push a new choice point onto the stack
	function pushChoice( ctx, choiceThunk ) {
	ctx.choices.unshift( { thunk:choiceThunk, trailIndex:ctx.trail.length } );
	}

	// Change the choice point on the top of the stack
	function setChoice( ctx, choiceThunk ) {
	ctx.choices[0].thunk = choice-thunk;
	}

	// Pop the top choice point and return it
	function popChoice( ctx ) {
	if( ctx.choices.length > 0 ) {
	return ctx.choices.shift();
	}

	return false;
	}

	// Whether there are any choice-points
	function hasChoices( ctx ) {
	return (ctx.choices.length > 0);
	}

	// Back-track to next available choice
	function backtrack( ctx ) {
	//console.log( "backtrack " + ctx );

	if( ctx.choices.length > 0 ) {
	var choice = ctx.choices[0];
	undoBindings( ctx.trail, choice.trailIndex );
	return choice.thunk;
	}
	return false;
	}

	// Make a variable
	function Variable() {}
	Variable.prototype.value = false;
	Variable.prototype.valueOf = function() { return this.value; }
	Variable.prototype.toString = function() { return this.value ? "{" + this.value + "}" : "VAR"; }
	function isVariable( v ) {
	return ( typeof v === "object"
	&& v.constructor === Variable );
	}

	//Structs
	function Struct(name,args) {
	this.name = name;
	this.args = args;
	}
	Struct.prototype.toString = function() { return this.name + "(" + this.args.toString() + ")"; }
	function isStruct( v ) {
	return ( typeof v === "object"
	&& v.constructor === Struct );
	}

	// Pairs
	function Pair( car, cdr ) {
	this.car = car;
	this.cdr = cdr;
	}
	Pair.prototype.toString = function() { return "pair<" + this.car + "," + this.cdr + ">"; }
	function isPair( v ) {
	return ( v && v.constructor === Pair );
	}
	var Empty = { toString:function(){ return "Empty"; }} ; //empty list

	// Undo variable bindings from the given index
	function undoBindings( trail, index ) {
	var trailSize = trail.length;

	for( var i = index; i < trailSize; i++ ) {
	delete trail[i].value;
	}

	trail.length = index;
	}

	function trampoline( fn ) {
	while( fn ) {
	fn = fn();
	//console.log( "fn=" + fn );
	}

	//console.log( "trampoline exiting" );
	}

	// Chase Variable contents until non-var or unbound
	function dereferenceTerm( maybeVar ) {
	while( isVariable( maybeVar ) ) {
	var value = maybeVar.value;
	if( value ) maybeVar = value;
	else break;
	}

	return maybeVar;
	}

	// Unify two terms
	// If unification succeeds return true.
	// If unification fails then undo all bindings back to the initial index and return false.
	function unify( ctx, a, b ) {
	var baseIndex = ctx.trail.length;
	if( unifyTrail( ctx.trail, a, b ) ) return true;
	undoBindings( ctx.trail, baseIndex );
	return false;
	}

	// Unify two terms and push new bindings on to the trail.
	function unifyTrail( trail, a, b ) {
	if( a == b ) return true; //takes care of numbers, atoms and strings

	//lists and improper lists
	if( isPair(a) && isPair(b) ) {
	if( unifyTrail( trail, a.car, b.car )) return unifyTrail( trail, a.cdr, b.cdr );
	return false;
	}

	//structs
	if( isStruct(a) && isStruct(b)
	&& a.name == b.name
	&& a.args.length == b.args.length ) {
	for( var i = 0; i < a.args.length; i++ ) {
	if( ! unifyTrail( trail, a.args[i], B.args[i] )) return false;
	}
	return true;
	}

	//variables
	if( isVariable(a) \|\| isVariable(b) ) {
	a = dereferenceTerm(a);
	b = dereferenceTerm(b);
	var ref;
	var other;

	if( isVariable(a) ) {
	ref = a;
	other = b;
	}
	else if( isVariable(b) ) {
	ref = b;
	other = a;
	}
	else {
	return unifyTrail( trail, a, b );
	}

	//make variable binding
	ref.value = other;
	trail.push( ref );
	return true;
	}

	return false;
	}

	function arrayToList( ary ) {
	var list = Empty;
	for( var i = ary.length - 1; i >= 0; i-- ) {
	list = new Pair( ary[i], list );
	}

	return list;
	}

	function listToArray( list ) {
	list = dereferenceTerm(list);
	var ary = [];
	while( isPair(list) ) {
	ary.push( dereferenceTerm(list.car) );
	list = dereferenceTerm(list.cdr);
	}
	return ary;
	}

	function test() {
	var start = Date.now();
	var solns = 0;

	for( var i = 0; i < 10; i++ ) {
	solns = 0;
	run_queens( function(a) { solns++; } );
	}

	var end = Date.now();

	var log = document.getElementById( "log" );
	log.innerHTML += "Time = " + ((end-start)/10) + "<br />";
	log.innerHTML += "Count = " + solns + "<br />";
	}

	function clear() {
	var log = document.getElementById( "log" );
	log.innerHTML = "";
	}

	function solutions() {
	var log = document.getElementById( "log" );
	log.innerHTML = "";
	run_queens( function(a) { log.innerHTML += listToArray(a) + "<br />"; } );
	}

	function run_queens( callback ) {
	var ctx = makeContext();
	var A = new Variable();
	trampoline( function() {
	return board_1( ctx, function() {
	return queens_1( ctx, function() {
	callback(A);
	return backtrack( ctx );
	}, A );
	}, A );
	});
	}

	function board_1( ctx, cont, A ) {
	if( unify( ctx, arrayToList([
	new Struct( "/", [1, new Variable()] ),
	new Struct( "/", [2, new Variable()] ),
	new Struct( "/", [3, new Variable()] ),
	new Struct( "/", [4, new Variable()] ),
	new Struct( "/", [5, new Variable()] ),
	new Struct( "/", [6, new Variable()] ),
	new Struct( "/", [7, new Variable()] ),
	new Struct( "/", [8, new Variable()] )
	]), A )) {
	return cont;
	}

	return backtrack(ctx);
	}

	function queens_1( ctx, cont, A ) {
	A = dereferenceTerm(A);
	pushChoice( ctx, function() {
	popChoice( ctx ); //no more clauses
	var Row, Col, Rest;
	var success;

	if( isVariable(A) ) {
	Row = new Variable();
	Col = new Variable();
	Rest = new Variable();
	unify( ctx, new Pair( new Struct("/",[Row,Col]), Rest), A );
	success = true;
	}
	else if( isPair(A) && isStruct(A.car)
	&& A.car.name == "/" && A.car.args.length == 2 ) {

	Row = dereferenceTerm(A.car.args[0]);
	Col = dereferenceTerm(A.car.args[1]);
	Rest = dereferenceTerm(A.cdr);
	success = true;
	}
	else success = false;

	if( success ) {
	return function() {
	return queens_1( ctx, function() {
	return member_2( ctx, function() {
	return safe_2( ctx, cont, new Struct("/",[Row,Col]), Rest );
	}, Col, arrayToList([1,2,3,4,5,6,7,8]));
	}, Rest );
	}
	}

	return backtrack( ctx );
	});

	if( A === Empty ) return cont;
	return backtrack( ctx );
	}

	function safe_2( ctx, cont, A, B ) {
	A = dereferenceTerm(A);
	B = dereferenceTerm(B);
	pushChoice( ctx, function() {
	popChoice( ctx ); //no more clauses
	var Row, Col, Row1, Col1, Rest;
	var success;

	if( isVariable(A) ) {
	Row = new Variable();
	Col = new Variable();
	unify( ctx, new Struct("/",[Row,Col]), A );
	success = true;
	}
	else if( isStruct(A) && A.name == "/" && A.args.length == 2 ) {
	Row = dereferenceTerm(A.args[0]);
	Col = dereferenceTerm(A.args[1]);
	success = true;
	}
	else success = false;

	if( success ) {
	if( isVariable(B) ) {
	Row1 = new Variable();
	Col1 = new Variable();
	Rest = new Variable();
	unify( ctx, new Pair( new Struct("/",[Row1,Col1]), Rest), B );
	success = true;
	}
	else if( isPair(B) && isStruct(B.car)
	&& B.car.name == "/" && B.car.args.length == 2 ) {

	Row1 = dereferenceTerm(B.car.args[0]);
	Col1 = dereferenceTerm(B.car.args[1]);
	Rest = dereferenceTerm(B.cdr);
	success = true;
	}
	else success = false;
	}

	if( success
	&& Col != Col1
	&& (Col1 - Col) != (Row1 - Row)
	&& (Col1 - Col) != (Row - Row1)) {

	return function() { return safe_2( ctx, cont, new Struct("/", [Row, Col] ) , Rest ); }
	}

	return backtrack( ctx );
	});

	if( B === Empty ) return cont;
	return backtrack( ctx );
	}

	function member_2( ctx, cont, A, B ) {
	//console.log( "member_2 " + A.toString() + " " + B.toString() );

	A = dereferenceTerm(A);
	B = dereferenceTerm(B);
	pushChoice( ctx, function() {
	//console.log( "member_2.2 " + A.toString() + " " + B.toString() );
	popChoice( ctx ); //no more clauses
	var Tail;
	var success;
	if( isVariable(B) ) {
	Tail = new Variable();
	unify( ctx, new Pair( new Variable(), Tail ), B );
	success = true;
	}
	else if( isPair(B) ) {
	Tail = dereferenceTerm( B.cdr );
	success = true;
	}
	else success = false;

	if( success ) return function() { return member_2( ctx, cont, A, Tail ); }

	return backtrack( ctx );
	});

	//console.log( "member_2.1 " + A.toString() + " " + B.toString() );
	if( isPair(B) && unify( ctx, A, B.car )) {
	//console.log( "OK " + cont );
	return cont;
	}

	return backtrack( ctx );
	}

	/*
	var ctx = makeContext();
	var A = new Variable();
	trampoline( member_2( ctx,
	function() { console.log( "A=" + A.value ); return backtrack( ctx ); },
	A,
	arrayToList([1,2,3,4,5,6,7,8]) ));
	*/

	</script>
	</head>
	<body>
	<a href="javascript:test()">Test</a> \|
	<a href="javascript:solutions()">Solutions</a> \|
	<a href="javascript:clear()">Clear</a>
	<hr />
	<div id="log"></log>

	</body>
	</html>
	#lang racket

	(define (make-context)
	(vector null ; 0 choice stack
	null ; 1 undo trail
	#f ; 2 halted ?
	))

	;; Push a new choice point onto the stack
	(define (push-choice! ctx choice-thunk)
	(vector-set! ctx 0
	(cons (vector choice-thunk ; choice is vector since may want to add other state later
	(vector-ref ctx 1)) ; capture the undo-trail for backtracking
	(vector-ref ctx 0))))

	;; Change the choice point on the top of the stack
	(define (set-choice! ctx choice-thunk)
	(vector-set! (car (vector-ref ctx 0) 0 choice-thunk)))

	;; Pop the top choice point and return it
	(define (pop-choice! ctx)
	(let ([top (vector-ref ctx 0)])
	(if (not (null? top))
	(begin
	(vector-set! ctx 0 (cdr top))
	(car top))
	#f)))

	;; Whether there are any choice-points
	(define (has-choices? ctx) (not (null? (vector-ref ctx 0))))

	;; Back-track to next available choice
	(define (backtrack ctx)
	(let* ([top (vector-ref ctx 0)]
	[choice (if (not (null? top)) (car top) #f)])
	(if choice
	(let ([choice-thunk (vector-ref choice 0)]
	[trail-base (vector-ref choice 1)])
	(undo-bindings-ctx ctx trail-base)
	(choice-thunk))
	#f)))

	;; Undo variable bindings after the given one (exclusive), and update the context.
	;; Assumes variables are boxes.
	(define (undo-bindings-ctx ctx binding)
	(undo-bindings (vector-ref ctx 1) binding)
	(vector-set! ctx 1 binding))

	;; Undo variable bindings from the head to the tail (exclusive)
	(define (undo-bindings head tail)
	(unless (eq? head tail)
	(set-box! (car head) #f) ; undo binding
	(undo-bindings (cdr head) tail)))

	;; Push a variable binding onto the trail
	(define (push-binding ctx variable)
	(vector-set! ctx 1 (cons variable (vector-ref ctx 1))))

	;; Unify two terms and add to the trail - #t if success, #f otherwise
	(define (unify ctx a b)
	(let* ([trail-base (vector-ref ctx 1)]
	[trail-head (unify-trail trail-base trail-base a b)])
	(if trail-head
	(begin (when (not (eq? trail-head trail-base))
	(vector-set! ctx 1 trail-head))
	#t)
	#f)))

	;; Create a new variable
	(define (new-variable) (box #f))

	;; Unify two terms and cons new bindings onto the trail-head.
	;; If unification succeeds return the new trail-head.
	;; If unification fails then undo all bindings back to the trail-base (exclusive)
	;; and return #f.
	(define (unify-trail trail-head trail-base a b)
	;(printf "unify-trail ~a ~a\n" a b)

	(cond
	[(eqv? a b) trail-head] ; takes care of symbols (atoms), numbers and identical objects
	[(and (string? a) (string? b) (equal? a b)) trail-head]

	; lists and improper lists
	[(and (pair? a) (pair? b))
	(let ([car-unification (unify-trail trail-head trail-base (car a) (car b))])
	(if car-unification
	(unify-trail car-unification trail-base (cdr a) (cdr b))
	#f))]

	; variables
	[(or (box? a) (box? b))
	(let ([deref-a (dereference-term a)]
	[deref-b (dereference-term b)])
	; Determine primary reference and value to unify with it
	(let-values ([(ref other) (cond
	[(box? deref-a) (values deref-a deref-b)]
	[(box? deref-b) (values deref-b deref-a)]
	[else (values #f #f)])])
	(if ref
	; make variable binding and add to trail
	(begin
	(set-box! ref other)
	(cons ref trail-head))
	; neither is a ref (after dereferencing) - unify
	(unify-trail trail-head trail-base deref-a deref-b))))]

	[else
	; (printf "unify-fail\n")
	(undo-bindings trail-head trail-base) #f]))

	;(define-syntax

	;; Chase box contents until non-box or empty box
	(define (dereference-term maybe-box)
	(if (box? maybe-box)
	(let ([value (unbox maybe-box)])
	(if value
	(dereference-term value)
	maybe-box))
	maybe-box))


	;; Backtrack through all solutions of the given query.
	;; The query is a proc of the form λ(ctx continue).
	(define (all-solutions query)
	(let ([ctx (make-context)])
	(query ctx (thunk (backtrack ctx)))))

	(define-syntax with-vars
	(syntax-rules ()
	[(_ (var-name ... ) body ...)
	(let ([var-name (new-variable)]
	...)
	body ...)]))

	(define-syntax init-vars
	(syntax-rules ()
	[(_ (var-name ... ) body ...)
	(begin (set! var-name (new-variable))
	...
	body ...)]))

	(define (test)
	(let ([start (current-inexact-milliseconds)]
	[solns null]
	[ctx (make-context)])
	(let loop ([iteration 1])
	(set! solns null)
	(with-vars
	(A)
	(board/1 ctx
	(thunk (queens/1
	ctx
	(thunk (set! solns (cons (dereference-term A) solns))
	(backtrack ctx))
	A))
	A))
	(when (< iteration 1000) (loop (+ iteration 1))))
	(printf "Time = ~a\n" (/ (- (current-inexact-milliseconds) start) 1000))
	(printf "Count: ~a\n" (length solns))
	))



	(define (run_queens/1 ctx continue)
	(with-vars
	(A)
	(board/1 ctx
	(thunk (queens/1
	ctx
	(thunk (printf "hello ~a\n" A)
	(continue))
	A))
	A)))

	(define (board/1 ctx continue A)
	(with-vars
	(C1 C2 C3 C4 C5 C6 C7 C8)
	(if (unify ctx (list (list '/ 1 C1)
	(list '/ 2 C2)
	(list '/ 3 C3)
	(list '/ 4 C4)
	(list '/ 5 C5)
	(list '/ 6 C6)
	(list '/ 7 C7)
	(list '/ 8 C8))
	A)
	(continue)
	(backtrack ctx))))

	(define (queens/1 ctx continue A)
	(set! A (dereference-term A))
	(push-choice!
	ctx
	(thunk (pop-choice! ctx)
	(let ([Row #f][Col #f][Rest #f])
	(if (match A
	[(box _)
	(init-vars (Row Col Rest) (unify ctx (cons (list '/ Row Col) Rest) A))]
	[(cons (list '/ @Row @Col) @Rest)
	(set! Row (dereference-term @Row))
	(set! Col (dereference-term @Col))
	(set! Rest (dereference-term @Rest))]
	[_ #f])
	(queens/1 ctx
	(thunk
	(member/2 ctx
	(thunk
	(safe/2 ctx continue (list '/ Row Col) Rest))
	Col '(1 2 3 4 5 6 7 8)))
	Rest)

	(backtrack ctx)))))

	(if (null? A)
	(continue)
	(backtrack ctx)))

	(define (safe/2 ctx continue A B)
	(set! A (dereference-term A))
	(set! B (dereference-term B))
	(push-choice!
	ctx
	(thunk (pop-choice! ctx)
	(let ([Row #f][Col #f][Row1 #f][Col1 #f][Rest #f])
	(if (and (match A
	[(box _) (init-vars (Row Col) (unify ctx (list '/ Row Col) A))]
	[(list '/ @Row @Col)
	(set! Row (dereference-term @Row))
	(set! Col (dereference-term @Col))]
	[_ #f])

	(match B
	[(box _) (init-vars (Row1 Col1 Rest)
	(unify ctx (cons (list '/ Row1 Col1) Rest) B))]
	[(cons (list '/ @Row @Col) @Rest)
	(set! Row1 (dereference-term @Row))
	(set! Col1 (dereference-term @Col))
	(set! Rest (dereference-term @Rest))]
	[_ #f])

	(not (= Col Col1))
	(not (= (- Col1 Col) (- Row1 Row)))
	(not (= (- Col1 Col) (- Row Row1))))
	(safe/2 ctx continue (list '/ Row Col) Rest)
	(backtrack ctx)))))

	(if (null? B)
	(continue)
	(backtrack ctx)))

	(define (member/2 ctx continue A B)
	(set! A (dereference-term A))
	(set! B (dereference-term B))
	(push-choice!
	ctx
	;; member(X, [Head \| Tail]) :- member(X, Tail).
	(thunk (pop-choice! ctx) ; no more clauses
	(let ([Tail #f])
	(if (match B
	[(box _) (init-vars (Tail) (unify ctx (cons (new-variable) Tail) B))]
	[(cons _ @Tail) (set! Tail (dereference-term @Tail))]
	[_ #f])

	(member/2 ctx continue A Tail)
	(backtrack ctx)))))

	; member(X, [X \| Tail]).
	; X is alias for A
	; Tail is never used
	(if (match B
	[(cons @X _) (unify ctx A @X)]
	[_ #f])
	(continue)
	(backtrack ctx)))

	(all-solutions
	(λ(ctx continue)
	(with-vars
	(A)
	(member/2 ctx
	(thunk (printf "member: ~a\n" A)
	(continue))
	A '(1 2 3 4 5 6 7 8)))))