\ n-queens

\ in a style that implements backtracking through functional programming
\ and (partly) functional programming through run-time code generation.

\ This version is from <2002May12.222014@a0.complang.tuwien.ac.at>.
\ Read that posting and the preceding discussion for a rationale.

\ needs anslocal.fs
\ : endif postpone then ; immediate
\ : noop ;

8 constant N
create rows N allot \ for each row, the column that the queen stands on

: apply ( w [...,w--...] -- [...--...] )
    2>r :noname 2r> swap postpone literal compile, postpone ; ;

: map-range ( ... limit start [...,w--...] -- ... )
    { xt } ?do
	i xt execute
    loop ;

: check-queen-against ( ... ) { col2 row1 row2 (...,col2--...) -- ... }
    \ check queen at row1 in ROWS against queen in row2/col2.
    \ This could be split into three filters, but that would not be easier.
    rows row1 + c@ ( column1 )
    dup col2 <> if \ different column?
	dup row1 + row2 - col2 <> if \ different first diagonal
	    dup row2 + row1 - col2 <> if \ different second diagonal
		drop
		col2 (...,col2--...) execute EXIT
	    endif
	endif
    endif
    drop ;

: place-queen ( ... ) { column row (...--...) -- ... }
    \ place queen at row/column in ROWS; a consumer, not a filter
    column rows row + c!
    (...--...) execute ;

: print-queen ( row -- )
    rows + c@ 3 .r ;

: print-queens ( -- )
    cr n 0 ['] print-queen map-range ;

\ the execution sequence of generators etc. that we want is:

\ map-range place-queen map-range check-queen-against place-queen ...
\ ... map-range check-queen-against ...  check-queen-against
\ place-queen print-queens

\ We need to pass the xt of print-queens to place-queen, etc., i.e.,
\ process the xts with APPLY in reverse order.  This is unintuitive;
\ we want to specify the xts and their arguments (except the
\ continuation) in normal order; we put all the xts and their
\ arguments on the stack at first, interleaved with xts for processing
\ them.  In the end we call EXECUTE to start processing the whole
\ stuff.  Read GEN-QUEENS first, then the other words.

\ Each YAPPLY wraps one generator/filter/consumer up, and then
\ EXECUTEs the next YAPPLY (or, in the end, NOOP).

: yapply1 ( ... xt1 w [w,xt2--] xt2 -- )
    swap apply apply swap execute ;

' yapply1 constant xapply1

: yapply2 ( ... xt1 w1 w2 [w1,w2,xt2--] xt2 -- )
    swap apply apply apply swap execute ;

' yapply2 constant xapply2

: gen-queens ( -- [--] )
    ['] noop \ when all APPLYs are done, the last EXECUTE uses this
    N 0 ?do
	N 0 ['] map-range xapply2
	i 0 ?do
	    i j ['] check-queen-against xapply2
	loop
	i ['] place-queen xapply1
    loop
    ['] print-queens
    swap execute ;
    
gen-queens execute