Created
May 15, 2013 19:04
-
-
Save nickmain/5586439 to your computer and use it in GitHub Desktop.
8 queens problem, handwritten JS and Scheme with the intention of eventually being generated by a Prolog compiler written in Racket
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
<!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> |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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))))) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment