From 67d25d837ac55f28a366c0a3b262e439a6e75fc3 Mon Sep 17 00:00:00 2001 From: Dimitri Sokolyuk Date: Sat, 19 Aug 2017 12:15:28 +0200 Subject: Add AmForth --- amforth-6.5/examples/queens.frt | 54 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 amforth-6.5/examples/queens.frt (limited to 'amforth-6.5/examples/queens.frt') diff --git a/amforth-6.5/examples/queens.frt b/amforth-6.5/examples/queens.frt new file mode 100644 index 0000000..e20b05d --- /dev/null +++ b/amforth-6.5/examples/queens.frt @@ -0,0 +1,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" ; + -- cgit v1.2.3