Paste: knight tours - beta version
Author: | prunedtree |
Mode: | factor |
Date: | Tue, 2 Dec 2008 17:08:37 |
Plain Text |
USING: accessors arrays assocs combinators io kernel locals
math math.matrices math.matrices math.order math.ranges
math.vectors prettyprint printf printf sequences sorting ;
IN: ktour
: all-pairs [ ] [ length ] [ <repetition> flip ] tri [ zip ] with map concat ;
: knight-moves -2 2 [a,b] all-pairs [ { 1 2 } [ norm ] bi@ = ] filter ;
USE: printf
: show [ [ "%5d" printf ] each nl ] each ;
: nth/out [ [ bounds-check? ] [ [ nth ] 2curry ] 2bi ] [ [ ] curry ] bi* if ;
: deep
over length 1 > [ [ unclip-slice ] [ nth ] bi* deep ] [ [ first ] [ ] bi* ] if ;
TUPLE: ktour
{ board read-only }
{ k read-only }
{ pair read-only } ;
: <ktour> ktour new ;
:: >>board tuple [ drop value ] [ k>> ] [ pair>> ] tri ktour boa ; inline
:: >>k tuple [ board>> ] [ drop value ] [ pair>> ] tri ktour boa ; inline
:: >>pair tuple [ board>> ] [ k>> ] [ drop value ] tri ktour boa ; inline
: >pair> [ [ pair>> ] dip call ] 2keep drop swap >>pair ; inline
: >k> [ [ k>> ] dip call ] 2keep drop swap >>k ; inline
: n>> board>> length ; inline
: valid [ pair>> first2 swap ] [ board>> ] bi { } nth/out f nth/out 0 = ;
: valid-moves
[ knight-moves ] [ [ [ v+ ] >pair> ] curry ] bi* map [ valid ] filter ;
: valid-moves-count valid-moves length ;
USE: math.matrices
USE: sequences.deep
: (solve)
{ [ ] [ k>> ] [ pair>> ] [ board>> ] } cleave deep set-nth
[ ] [ k>> ] [ n>> sq ] tri <
[
f swap
[ valid-moves [ [ valid-moves-count ] compare ] sort ] keep
[
[ [ 1+ ] >k> (solve) ]
[ [ drop 0 ] [ pair>> ] [ board>> ] tri deep set-nth ] bi*
nip dup
] curry find 2drop
] [ dup board>> show ] if ;
: solve
<ktour>
swap dup zero-matrix >>board
1 >>k
{ 0 0 } >>pair
(solve) drop ;
Author: | prunedtree |
Mode: | factor |
Date: | Tue, 2 Dec 2008 17:16:01 |
Plain Text |
: n>> board>> length ; inline
: all-pairs [ ] [ length ] [ <repetition> flip ] tri [ zip ] with map concat ;
: knight-moves -2 2 [a,b] all-pairs [ { 1 2 } [ norm ] bi@ = ] filter ;
: show [ [ "%5d" printf ] each nl ] each ;
: nth/out [ [ bounds-check? ] [ [ nth ] 2curry ] 2bi ] [ [ ] curry ] bi* if ;
: deep over length 1 > [ [ unclip-slice ] [ nth ] bi* deep ] [ [ first ] [ ] bi* ] if ;
: valid [ pair>> first2 swap ] [ board>> ] bi { } nth/out f nth/out 0 = ;
: valid-moves [ knight-moves ] [ [ [ v+ ] >pair> ] curry ] bi* map [ valid ] filter ;
: valid-moves-count valid-moves length ;
: trace [ k>> ] [ pair>> ] [ board>> ] tri deep set-nth ;
: sorted-moves [ valid-moves [ [ valid-moves-count ] compare ] sort ] keep ;
: untrace [ drop 0 ] [ pair>> ] [ board>> ] tri deep set-nth ;
: (solve)
dup trace
[ ] [ k>> ] [ n>> sq ] tri <
[ f swap sorted-moves [ [ [ 1+ ] >k> (solve) ] [ untrace ] bi* nip dup ] curry find 2drop ]
[ dup board>> show ] if ;
: solve <ktour> swap dup zero-matrix >>board 1 >>k { 0 0 } >>pair (solve) drop ;
New Annotation