Paste: knight tours - beta version

! 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 ] [ <repetition> 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 ) 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 -- )
  <ktour>
  swap dup zero-matrix >>board
  1 >>k
  { 0 0 } >>pair
  (solve) drop ;

Annotation: core logic < 20 lines

: n>> board>> length ; inline
: all-pairs ( seq -- seqs ) [ ] [ length ] [ <repetition> flip ] tri [ zip ] with map concat ;
: knight-moves ( -- pairs ) -2 2 [a,b] all-pairs [ { 1 2 } [ norm ] bi@ = ] filter ;
: 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 ;
: 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 ;
: trace ( ktour -- ) [ k>> ] [ pair>> ] [ board>> ] tri deep set-nth ;
: sorted-moves ( ktour -- moves ) [ valid-moves [ [ valid-moves-count ] compare ] sort ] keep ;
: untrace ( ktour -- ) [ drop 0 ] [ pair>> ] [ board>> ] tri deep set-nth ;

: (solve) ( ktour -- ktour/f )
  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 ( n -- ) <ktour> swap dup zero-matrix >>board 1 >>k { 0 0 } >>pair (solve) drop ;

New Annotation