Received: by 10.66.81.170 with SMTP id b10mr5929504pay.31.1352609581377;
        Sat, 10 Nov 2012 20:53:01 -0800 (PST)
Path: s9ni4461pbb.0!nntp.google.com!news.glorb.com!eternal-september.org!feeder.eternal-september.org!mx04.eternal-september.org!.POSTED!not-for-mail
From: arc <arc.deletet...@vorsicht-bissig.de>
Newsgroups: comp.lang.forth
Subject: Re: coin changer --- a challenge for novices
Date: Sun, 11 Nov 2012 17:53:00 +1300
Organization: A noiseless patient Spider
Lines: 204
Message-ID: <87txswpwpf.fsf@vorsicht-bissig.de>
References: <a9cb961d-eef1-4578-9efc-ede0c3cfbdef@i2g2000pbi.googlegroups.com>
Mime-Version: 1.0
Injection-Info: mx04.eternal-september.org; posting-host="ded1ac4a48cb4c49b2099faa93543fd2";
	logging-data="8006"; mail-complaints-to="ab...@eternal-september.org";	posting-account="U2FsdGVkX19TpKCv/A4MPHGk6zvH9YcU"
User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/23.3 (gnu/linux)
Cancel-Lock: sha1:AC7SztaUVbIcCRDnFAC7wsBgXNI=
	sha1:TO4hZ5Irjdsf1vOBNT4l0K72ar8=
Content-Type: text/plain; charset=us-ascii


>
> As a slightly more advanced challenge (still pretty easy), solve the N-
> Queens problem. I don't think this appears anywhere in SICP, but I
> have a solution in my novice package (
> http://www.forth.org/novice.html). As a bonus challenge --- make your
> program non-recursive as I did (the N-Queens problem is a classic
> example of recursive-descent searching in many textbooks).

Here is my non-recursive n-queens solution. 

I'm still pretty green with forth, so comments welcome. 

-arc. 

\ \\\\\\\\\\
\  nqueens.fs

( basic usage:
 create-queens dup n-queens
 dup .board  \ displays a chessboard
 dup .queens \ displays coordinates of queens
 set N to solve for Ns other than 8. )

variable N 
8 N !

: 3dup
    dup 2over rot ; 

\ \\\\\\\\\\\\\\\\\\\\\\
\ RNG

( Fast Random Number Generator
algorithm by George Marsaglia "Xorshift RNGs"

Arnold Doray's version posted to comp.lang.forth Sat, 17 Dec 2011
message id:  <jch8b0$d5...@dont-email.me>
) 

\ Xorshift (13,17,5)
: xorshift ( n -- n )
  dup 13 lshift xor
  dup 17 rshift xor
  dup  5 lshift xor ;

variable (rnd)     \ seed
2463534242 (rnd) ! \ initialize seed

: rnd ( -- n )
   (rnd) @ xorshift dup (rnd) ! ; 

: random-index
    rnd n @ mod ;

\ \\\\\\\\\\\\\\\\\\\\
\ Queens and their operations

2 cells constant QUEEN-SIZE

: create-queens ( - queens-addr )
    here
    N @ QUEEN-SIZE * allot ;

: queen.x ( queen-addr - x )
    @ ;

: queen.x! ( x queen-addr - )
    ! ;

: queen.y ( queen-addr - y )
    1 cells + @ ;

: queen.y! ( y queen-addr - )
    1 cells + ! ;

: queen.xy! ( x y queen-addr - )
    2dup queen.y!
    swap drop queen.x! ; 

: queens.queen-i ( queens-addr n - queen-addr ) 
    queen-size * + ;
    
: queens-bounds ( queens-addr - upper-bound lower-bound)
    N @ QUEEN-SIZE * bounds ;


: .queens ( queens-addr - )
    cr
    queens-bounds ?do
	i dup . [char] : emit space
	dup queen.x .
	queen.y . cr
    queen-size +loop ;

: clear-queens ( queens-addr - )
    queens-bounds ?do
	-1 i queen.x!
	-1 i queen.y!
    queen-size +loop ; 
	
	
: queen-there ( x y queens-addr - f )
    queens-bounds ?do
	over i queen.x = 
	over i queen.y  =
	and
	if 2drop -1 unloop exit then
    queen-size +loop
    2drop 0  ;

	
	
: setup-queens ( queens-addr - )
    dup queens-bounds ?do ( queens-addr )
	begin
	    random-index random-index  ( queens-addr x y )
	    3dup rot
	    queen-there ( queens-addr x y f )
	while 2drop repeat  ( queens-addr x y )
	i  queen.xy!
    queen-size +loop drop ; 

\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ board display

: .board-rowborder ( n - )
    [char] + emit
    0 ?do
	[char] - emit [char] + emit
    loop cr ; 
	
    
: .board ( queens-addr - )
    cr
   space space space N @ 0 ?do i . loop cr
   space space N @ .board-rowborder
    N @ 0 ?do i . 
	[char] | emit 	
	N @ 0 ?do
	   dup   j i rot  queen-there if [char] Q emit else space then
	    [char] | emit
	loop cr
	space space N @ .board-rowborder
    loop drop ; 
   
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\ attack detection

: on-same-col ( queens-addr queens-addr - f )
    queen.y swap queen.y = ;

: on-same-row ( queens-addr queens-addr - f)
    queen.x swap queen.x = ;

: on-same-diagonal ( queen-addr queen-addr - f )
    2dup queen.x swap queen.x - abs -rot ( xdiff queen-addr queen-addr )
    queen.y swap queen.y - abs ( xdiff ydiff)
    = ;

: queen-attack ( queen-addr queen-addr - f )
    2dup = if 2drop 0 exit then
    2dup on-same-row if 2drop -1 exit then
    2dup on-same-col if 2drop -1 exit then
    2dup on-same-diagonal if 2drop -1 exit then
    2drop 0
;

: queen-attacked ( queens-addr queen-addr - f )
    swap queens-bounds  ?do
	dup i queen-attack  if drop -1 unloop exit then
    queen-size  +loop
    drop 0
; 

: any-queens-attacked ( queens-addr - f )
    dup queens-bounds ?do
	dup i queen-attacked if drop -1 unloop exit then
     queen-size +loop
    drop 0
;

\ \\\\\\\\\\\\\\\\\\
\ nqueens
    
variable iterations

: n-queens ( queens-addr )
    0 iterations !
    begin
	iterations @ 1 + iterations !
	dup clear-queens
	dup setup-queens
	dup any-queens-attacked
	invert
    until
    drop
;


\ uncomment this to get an explicit solution example 
\ create explicit-solution 0 , 3 , 1 , 5 , 2 , 7 , 3 , 1 , 4 , 6 , 5 , 0 , 6 , 2 , 7 , 4 ,