! Copyright (C) 2008 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. 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 ( seq -- seqs ) [ ] [ length ] [ flip ] tri [ zip ] with map concat ; : knight-moves ( -- pairs ) -2 2 [a,b] all-pairs [ { 1 2 } [ norm ] bi@ = ] filter ; USE: printf : show ( matrix -- ) [ [ "%5d" printf ] each nl ] each ; : nth/out ( n seq out -- elt ) [ [ bounds-check? ] [ [ nth ] 2curry ] 2bi ] [ [ ] curry ] bi* if ; : deep ( n-seq obj -- last-n seq ) 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 ; ! these should be in value-accessors :: >>board ( tuple value -- tuple' ) tuple [ drop value ] [ k>> ] [ pair>> ] tri ktour boa ; inline :: >>k ( tuple value -- tuple' ) tuple [ board>> ] [ drop value ] [ pair>> ] tri ktour boa ; inline :: >>pair ( tuple value -- tuple' ) tuple [ board>> ] [ k>> ] [ drop value ] tri ktour boa ; inline : >pair> ( tuple quot -- tuple' ) [ [ pair>> ] dip call ] 2keep drop swap >>pair ; inline : >k> ( tuple quot -- tuple' ) [ [ k>> ] dip call ] 2keep drop swap >>k ; inline : n>> board>> length ; inline : valid ( ktour -- ? ) [ pair>> first2 swap ] [ board>> ] bi { } nth/out f nth/out 0 = ; : valid-moves ( ktour -- seq ) [ knight-moves ] [ [ [ v+ ] >pair> ] curry ] bi* map [ valid ] filter ; : valid-moves-count ( ktour -- k ) valid-moves length ; USE: math.matrices USE: sequences.deep : (solve) ( ktour -- ktour/f ) { [ ] [ 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 ( n -- ) swap dup zero-matrix >>board 1 >>k { 0 0 } >>pair (solve) drop ;