aboutsummaryrefslogtreecommitdiff
path: root/amforth-6.5/examples/queens.frt
blob: e20b05de314b149e5d016173801d9c3a409660ae (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
\ Copyright (c) 2007 the authors listed at the following URL, and/or
\ the authors of referenced articles or incorporated external code:
\ http://en.literateprograms.org/Eight_queens_puzzle_(Forth)?action=history&offset=20070512025943
\ 
\ Permission is hereby granted, free of charge, to any person obtaining
\ a copy of this software and associated documentation files (the
\ "Software"), to deal in the Software without restriction, including
\ without limitation the rights to use, copy, modify, merge, publish,
\ distribute, sublicense, and/or sell copies of the Software, and to
\ permit persons to whom the Software is furnished to do so, subject to
\ the following conditions:
\ 
\ The above copyright notice and this permission notice shall be
\ included in all copies or substantial portions of the Software.
\ 
\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
\ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
\ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
\ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
\ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
\ 
\ Retrieved from: http://en.literateprograms.org/Eight_queens_puzzle_(Forth)?oldid=10015
marker queen

 : bits ( bits -- mask ) 1 swap lshift 1- ;
 : lowBit  ( mask -- bit ) dup negate and ;
 : lowBit- ( mask -- mask ) dup 1- and ;
 : third ( a b c -- a b c a ) 2 pick ;

 variable solutions
 variable nodes
 : poss ( a b c -- a b c a&b&c ) dup 2over and and ;

 : next3 ( dl dr f Qfilebit -- dl dr f dl' dr' f' )
   invert >r
   third r@ and 2* 1+
   third r@ and 2/
   third r> and ;

 : try ( dl dr f -- )             \ bitmasks for unused diagonals and files
   dup if 1 nodes +!  poss
     begin ?dup while
       dup >r lowBit next3 recurse r> lowBit-
     repeat
   else ( .sol) 1 solutions +! then
   drop drop drop ;

 : queens ( n -- ) >r
   0 solutions ! 0 nodes !
   -1 dup r@ bits try
   r> . ." queens: " solutions @ u. ." solutions, " nodes @ u. ." nodes" ;