Fixing various test failures and updating some more vocabs for >r/r> removal

db4
Slava Pestov 2008-12-17 22:29:32 -06:00
parent 4dd615fa9e
commit 5fdb474c76
30 changed files with 79 additions and 79 deletions

View File

@ -79,7 +79,7 @@ IN: compiler.tree.dead-code.tests
[ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test
[ [ over [ + ] dip ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
[ [ over >R + R> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
[ [ [ ] [ ] if ] ] [ [ [ 1 ] [ 2 ] if drop ] optimize-quot ] unit-test

View File

@ -8,13 +8,13 @@ compiler.tree.debugger ;
: test-modular-arithmetic ( quot -- quot' )
build-tree optimize-tree nodes>quot ;
[ [ [ >fixnum ] dip >fixnum fixnum+fast ] ]
[ [ >R >fixnum R> >fixnum fixnum+fast ] ]
[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test
[ [ +-integer-integer dup >fixnum ] ]
[ [ { integer integer } declare + dup >fixnum ] test-modular-arithmetic ] unit-test
[ [ [ >fixnum ] dip >fixnum fixnum+fast 4 fixnum*fast ] ]
[ [ >R >fixnum R> >fixnum fixnum+fast 4 fixnum*fast ] ]
[ [ { integer integer } declare + 4 * >fixnum ] test-modular-arithmetic ] unit-test
TUPLE: declared-fixnum { x fixnum } ;

View File

@ -20,13 +20,13 @@ M: thread send ( message thread -- )
my-mailbox mailbox-get ?linked ;
: receive-timeout ( timeout -- message )
my-mailbox swap mailbox-get-timeout ?linked ;
[ my-mailbox ] dip mailbox-get-timeout ?linked ;
: receive-if ( pred -- message )
my-mailbox swap mailbox-get? ?linked ; inline
[ my-mailbox ] dip mailbox-get? ?linked ; inline
: receive-if-timeout ( timeout pred -- message )
my-mailbox -rot mailbox-get-timeout? ?linked ; inline
[ my-mailbox ] 2dip mailbox-get-timeout? ?linked ; inline
: rethrow-linked ( error process supervisor -- )
[ <linked-error> ] dip send ;

View File

@ -56,7 +56,7 @@ sequences eval accessors ;
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test
[ "USING: fry kernel ; f '[ load-local _ ]" eval ]
[ "USING: fry locals.backend ; f '[ load-local _ ]" eval ]
[ error>> >r/r>-in-fry-error? ] must-fail-with
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [

View File

@ -360,7 +360,7 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
{ $list
"Factor only makes use of one native thread, and Factor threads are scheduled co-operatively. C library calls block the entire VM."
"Factor does not hide anything from the programmer, all internals are exposed. It is your responsibility to avoid writing fragile code which depends too much on implementation detail."
{ "When a source file uses two vocabularies which define words with the same name, the order of the vocabularies in the " { $link POSTPONE: USE: } " or " { $link POSTPONE: USING: } " forms is important. The parser prints warnings when vocabularies shadow words from other vocabularies; see " { $link "vocabulary-search-shadow" } ". The " { $vocab-link "qualified" } " vocabulary implements qualified naming, which can be used to resolve ambiguities." }
{ "When a source file uses two vocabularies which define words with the same name, the order of the vocabularies in the " { $link POSTPONE: USE: } " or " { $link POSTPONE: USING: } " forms is important. The " { $link POSTPONE: QUALIFIED: } " word implements qualified naming, which can be used to resolve ambiguities." }
{ "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." }
{ "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." }
{ "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by ``multiple inheritance'' in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." }

View File

@ -1,6 +1,6 @@
USING: io io.streams.string io.streams.duplex listener
tools.test parser math namespaces continuations vocabs kernel
compiler.units eval ;
compiler.units eval vocabs.parser ;
IN: listener.tests
: hello "Hi" print ; parsing

View File

@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order math.functions
definitions compiler.units fry lexer ;
definitions compiler.units fry lexer words.symbol ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;

View File

@ -57,8 +57,8 @@ io.files io.encodings.utf8 ;
[ "mate" ] [ "mate" step5 "" like ] unit-test
[ { } ] [
"resource:extra/porter-stemmer/test/voc.txt" utf8 file-lines
"resource:basis/porter-stemmer/test/voc.txt" utf8 file-lines
[ stem ] map
"resource:extra/porter-stemmer/test/output.txt" utf8 file-lines
"resource:basis/porter-stemmer/test/output.txt" utf8 file-lines
[ 2array ] 2map [ first2 = not ] filter
] unit-test

View File

@ -7,7 +7,7 @@ USING: kernel math parser sequences combinators splitting ;
] [
CHAR: y = [
over zero?
[ 2drop t ] [ >r 1- r> consonant? not ] if
[ 2drop t ] [ [ 1- ] dip consonant? not ] if
] [
2drop t
] if
@ -15,18 +15,18 @@ USING: kernel math parser sequences combinators splitting ;
: skip-vowels ( i str -- i str )
2dup bounds-check? [
2dup consonant? [ >r 1+ r> skip-vowels ] unless
2dup consonant? [ [ 1+ ] dip skip-vowels ] unless
] when ;
: skip-consonants ( i str -- i str )
2dup bounds-check? [
2dup consonant? [ >r 1+ r> skip-consonants ] when
2dup consonant? [ [ 1+ ] dip skip-consonants ] when
] when ;
: (consonant-seq) ( n i str -- n )
skip-vowels
2dup bounds-check? [
>r 1+ >r 1+ r> r> skip-consonants >r 1+ r>
[ 1+ ] [ 1+ ] [ ] tri* skip-consonants [ 1+ ] dip
(consonant-seq)
] [
2drop
@ -42,7 +42,7 @@ USING: kernel math parser sequences combinators splitting ;
over 1 < [
2drop f
] [
2dup nth >r over 1- over nth r> = [
2dup nth [ over 1- over nth ] dip = [
consonant?
] [
2drop f
@ -52,7 +52,7 @@ USING: kernel math parser sequences combinators splitting ;
: consonant-end? ( n seq -- ? )
[ length swap - ] keep consonant? ;
: last-is? ( str possibilities -- ? ) >r peek r> member? ;
: last-is? ( str possibilities -- ? ) [ peek ] dip member? ;
: cvc? ( str -- ? )
{

View File

@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint prettyprint.config
prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private
continuations generic compiler.units tools.walker eval
accessors make ;
accessors make vocabs.parser ;
IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test

View File

@ -6,7 +6,7 @@ quotations effects tools.test continuations generic.standard
sorting assocs definitions prettyprint io inspector
classes.tuple classes.union classes.predicate debugger
threads.private io.streams.string io.timeouts io.thread
sequences.private destructors combinators eval ;
sequences.private destructors combinators eval locals.backend ;
IN: stack-checker.tests
\ infer. must-infer
@ -320,7 +320,7 @@ DEFER: bar
: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
[ [ bad-bin ] infer ] must-fail
[ [ r> ] infer ] [ inference-error? ] must-fail-with
[ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with
! Regression
[ [ cleave ] infer ] [ inference-error? ] must-fail-with
@ -502,7 +502,7 @@ ERROR: custom-error ;
[ custom-error inference-error ] infer
] unit-test
[ T{ effect f 1 1 t } ] [
[ T{ effect f 1 2 t } ] [
[ dup [ 3 throw ] dip ] infer
] unit-test

View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors values kernel sequences assocs io.files
io.encodings ascii math.ranges io splitting math.parser
io.encodings ascii math.ranges io splitting math.parser
namespaces make byte-arrays locals math sets io.encodings.ascii
words compiler.units arrays interval-maps unicode.data ;
words words.symbol compiler.units arrays interval-maps
unicode.data ;
IN: unicode.script
<PRIVATE

View File

@ -136,7 +136,7 @@ ERROR: no-case ;
! recursive-hashcode
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
pick 0 <= [ 3drop 0 ] [ [ 1- ] 2dip call ] if ; inline
! These go here, not in sequences and hashtables, since those
! two cannot depend on us

View File

@ -1,7 +1,5 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
! Some low-level code used by vectors and string buffers.
USING: accessors kernel kernel.private math math.private
sequences sequences.private ;
IN: growable
@ -22,7 +20,7 @@ M: growable set-nth-unsafe underlying>> set-nth-unsafe ;
: contract ( len seq -- )
[ length ] keep
[ 0 -rot set-nth-unsafe ] curry
[ [ 0 ] 2dip set-nth-unsafe ] curry
(each-integer) ; inline
: growable-check ( n seq -- n seq )

View File

@ -17,7 +17,7 @@ IN: kernel.tests
[ ] [ :c ] unit-test
[ { } set-retainstack r> ] [ { "kernel-error" 13 f f } = ] must-fail-with
[ 3 [ { } set-retainstack ] dip ] [ { "kernel-error" 13 f f } = ] must-fail-with
[ ] [ :c ] unit-test
@ -35,7 +35,7 @@ IN: kernel.tests
[ ] [ [ :c ] with-string-writer drop ] unit-test
: overflow-r 3 >r overflow-r ;
: overflow-r 3 [ overflow-r ] dip ;
[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with

View File

@ -34,7 +34,7 @@ ARTICLE: "namespaces.private" "Namespace implementation details"
ARTICLE: "namespaces" "Variables and namespaces"
"The " { $vocab-link "namespaces" } " vocabulary implements simple dynamically-scoped variables."
$nl
"A variable is an entry in an assoc of bindings, where the assoc is implicit rather than passed on the stack. These assocs are termed " { $emphasis "namespaces" } ". Nesting of scopes is implemented with a search order on namespaces, defined by a " { $emphasis "namestack" } ". Since namespaces are just assoc, any object can be used as a variable, however by convention, variables are keyed by symbols (see " { $link "symbols" } ")."
"A variable is an entry in an assoc of bindings, where the assoc is implicit rather than passed on the stack. These assocs are termed " { $emphasis "namespaces" } ". Nesting of scopes is implemented with a search order on namespaces, defined by a " { $emphasis "namestack" } ". Since namespaces are just assoc, any object can be used as a variable, however by convention, variables are keyed by symbols (see " { $link "words.symbol" } ")."
$nl
"The " { $link get } " and " { $link set } " words read and write variable values. The " { $link get } " word searches up the chain of nested namespaces, while " { $link set } " always sets variable values in the current namespace only. Namespaces are dynamically scoped; when a quotation is called from a nested scope, any words called by the quotation also execute in that scope."
{ $subsection get }

View File

@ -2,7 +2,8 @@ USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files assocs
sequences strings io.files io.pathnames definitions
continuations sorting classes.tuple compiler.units debugger
vocabs vocabs.loader accessors eval combinators lexer ;
vocabs vocabs.loader accessors eval combinators lexer
vocabs.parser words.symbol ;
IN: parser.tests
\ run-file must-infer
@ -485,19 +486,19 @@ must-fail-with
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
[ "DEFER: blah" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
[ "DEFER: blahy" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
[
"IN: parser.tests : blah ; parsing FORGET: blah" eval
"IN: parser.tests : blahy ; parsing FORGET: blahy" eval
] [
error>> staging-violation?
] must-fail-with
! Bogus error message
DEFER: blah
DEFER: blahy
[ "IN: parser.tests USE: kernel TUPLE: blah < tuple ; : blah ; TUPLE: blah < tuple ; : blah ;" eval ]
[ error>> error>> def>> \ blah eq? ] must-fail-with
[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ; TUPLE: blahy < tuple ; : blahy ;" eval ]
[ error>> error>> def>> \ blahy eq? ] must-fail-with
[ ] [ f lexer set f file set "Hello world" note. ] unit-test
@ -511,14 +512,16 @@ SYMBOLS: a b c ;
DEFER: blah
[ ] [ "IN: symbols.tests GENERIC: blah" eval ] unit-test
[ ] [ "IN: symbols.tests USE: symbols SYMBOLS: blah ;" eval ] unit-test
[ ] [ "IN: parser.tests GENERIC: blah" eval ] unit-test
[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test
[ f ] [ \ blah generic? ] unit-test
[ t ] [ \ blah symbol? ] unit-test
[ "IN: symbols.tests USE: symbols SINGLETONS: blah blah blah ;" eval ]
[ error>> error>> def>> \ blah eq? ]
DEFER: blah1
[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval ]
[ error>> error>> def>> \ blah1 eq? ]
must-fail-with
IN: qualified.tests.foo
@ -548,8 +551,8 @@ EXCLUDE: qualified.tests.bar => x ;
[ 3 ] [ x ] unit-test
[ 4 ] [ y ] unit-test
[ "USE: qualified IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
[ error>> no-word-error? ] must-fail-with
[ "USE: qualified IN: qualified.tests RENAME: doesnotexist qualified.tests => blah" eval ]
[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ]
[ error>> no-word-error? ] must-fail-with

View File

@ -414,7 +414,7 @@ HELP: QUALIFIED:
{ $syntax "QUALIFIED: vocab" }
{ $description "Similar to " { $link POSTPONE: USE: } " but loads vocabulary with prefix." }
{ $examples { $example
"USING: prettyprint qualified ;"
"USING: prettyprint ;"
"QUALIFIED: math"
"1 2 math:+ ." "3"
} } ;
@ -423,7 +423,7 @@ HELP: QUALIFIED-WITH:
{ $syntax "QUALIFIED-WITH: vocab word-prefix" }
{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." }
{ $examples { $code
"USING: prettyprint qualified ;"
"USING: prettyprint ;"
"QUALIFIED-WITH: math m"
"1 2 m:+ ."
"3"
@ -445,7 +445,7 @@ HELP: RENAME:
{ $syntax "RENAME: word vocab => newname" }
{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." }
{ $examples { $example
"USING: prettyprint qualified ;"
"USING: prettyprint ;"
"RENAME: + math => -"
"2 3 - ."
"5"

View File

@ -3,7 +3,7 @@ USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
parser source-files words assocs classes.tuple definitions
debugger compiler.units tools.vocabs accessors eval
combinators ;
combinators vocabs.parser ;
! This vocab should not exist, but just in case...
[ ] [

View File

@ -35,8 +35,7 @@ $nl
"fee:append calls foe:append"
"foe:append calls sequences:append"
"12345678"
}
"The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ;
} ;
ARTICLE: "vocabulary-search-errors" "Word lookup errors"
"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies."

View File

@ -33,7 +33,7 @@ $nl
{ $subsection define-inline }
"Word definitions should declare their stack effect, unless the definition is completely trivial. See " { $link "effect-declaration" } "."
$nl
"All other types of word definitions, such as " { $link "symbols" } " and " { $link "generic" } ", are just special cases of the above." ;
"All other types of word definitions, such as " { $link "words.symbol" } " and " { $link "generic" } ", are just special cases of the above." ;
ARTICLE: "primitives" "Primitives"
"Primitives are words defined in the Factor VM. They provide the essential low-level services to the rest of the system."

View File

@ -1,7 +1,7 @@
USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations
vocabs continuations classes.tuple compiler.units
io.streams.string accessors eval ;
io.streams.string accessors eval words.symbol ;
IN: words.tests
[ 4 ] [

View File

@ -16,6 +16,6 @@ test1 dup *coresume . dup *coresume . dup *coresume . dup *coresume 2drop
: test3 ( -- co )
[ [ coyield* ] each ] cocreate ;
{ "c" "b" "a" } [ test3 { "a" "b" "c" } over coresume >r dup *coresume >r *coresume r> r> ] unit-test
{ "c" "b" "a" } [ test3 { "a" "b" "c" } over coresume [ dup *coresume [ *coresume ] dip ] dip ] unit-test
{ 4+2/3 } [ [ 1+ coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test

View File

@ -7,7 +7,7 @@ eval help io io.files io.pathnames io.streams.string kernel
lexer listener listener.private make math memoize namespaces
parser prettyprint prettyprint.config quotations sequences sets
sorting source-files strings tools.vocabs vectors vocabs
vocabs.loader ;
vocabs.loader vocabs.parser ;
IN: fuel

View File

@ -108,7 +108,7 @@ SYMBOL: boundaries
: ((d)) ( basis -- value ) boundaries get at ;
: dx.y ( x y -- vec ) >r ((d)) r> wedge ;
: dx.y ( x y -- vec ) [ ((d)) ] dip wedge ;
DEFER: (d)
@ -120,7 +120,7 @@ DEFER: (d)
: linear-op ( vec quot -- vec )
[
[
-rot >r swap call r> alt*n (alt+)
-rot [ swap call ] dip alt*n (alt+)
] curry assoc-each
] with-terms ; inline
@ -165,7 +165,7 @@ DEFER: (d)
swap call [ at 0 or ] curry map ; inline
: op-matrix ( domain range quot -- matrix )
rot [ >r 2dup r> (op-matrix) ] map 2nip ; inline
rot [ [ 2dup ] dip (op-matrix) ] map 2nip ; inline
: d-matrix ( domain range -- matrix )
[ (d) ] op-matrix ;
@ -176,7 +176,7 @@ DEFER: (d)
! Graded by degree
: (graded-ker/im-d) ( n seq -- null/rank )
#! d: C(n) ---> C(n+1)
[ ?nth ] 2keep >r 1+ r> ?nth
[ ?nth ] [ [ 1+ ] dip ?nth ] 2bi
dim-im/ker-d ;
: graded-ker/im-d ( graded-basis -- seq )
@ -188,13 +188,13 @@ DEFER: (d)
! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )
#! d: C(u,z) ---> C(u+2,z-1)
[ ?nth ?nth ] 3keep >r >r 2 + r> 1 - r> ?nth ?nth
[ ?nth ?nth ] 3keep [ [ 2 + ] dip 1 - ] dip ?nth ?nth
dim-im/ker-d ;
: bigraded-ker/im-d ( bigraded-basis -- seq )
dup length [
over first length [
>r 2dup r> spin (bigraded-ker/im-d)
[ 2dup ] dip spin (bigraded-ker/im-d)
] map 2nip
] with map ;
@ -224,13 +224,13 @@ DEFER: (d)
] if ;
: laplacian-matrix ( basis1 basis2 basis3 -- matrix )
dupd d-matrix m.m' >r d-matrix m'.m r> ?m+ ;
dupd d-matrix m.m' [ d-matrix m'.m ] dip ?m+ ;
: laplacian-betti ( basis1 basis2 basis3 -- n )
laplacian-matrix null/rank drop ;
: laplacian-kernel ( basis1 basis2 basis3 -- basis )
>r tuck r>
[ tuck ] dip
laplacian-matrix dup empty-matrix? [
2drop f
] [
@ -246,7 +246,7 @@ DEFER: (d)
dup length [ graded-triple ] with map ;
: graded-laplacian ( generators quot -- seq )
>r basis graded graded-triples [ first3 ] r> compose map ;
[ basis graded graded-triples [ first3 ] ] dip compose map ;
inline
: graded-laplacian-betti ( generators -- seq )
@ -273,12 +273,12 @@ DEFER: (d)
: bigraded-triples ( grid -- triples )
dup length [
over first length [
>r 2dup r> spin bigraded-triple
[ 2dup ] dip spin bigraded-triple
] map 2nip
] with map ;
: bigraded-laplacian ( u-generators z-generators quot -- seq )
>r [ basis graded ] bi@ tensor bigraded-triples r>
[ [ basis graded ] bi@ tensor bigraded-triples ] dip
[ [ first3 ] prepose map ] curry map ; inline
: bigraded-laplacian-betti ( u-generators z-generators -- seq )

View File

@ -88,7 +88,7 @@ TUPLE: slides < book ;
: prev-page ( book -- ) -1 change-page ;
: (strip-tease) ( data n -- data )
>r first3 r> head 3array ;
[ first3 ] dip head 3array ;
: strip-tease ( data -- seq )
dup third length 1- [

View File

@ -154,8 +154,7 @@ M: spheres-gadget distance-step ( gadget -- dz )
: (make-reflection-framebuffer) ( depthbuffer -- framebuffer )
gen-framebuffer dup [
swap >r
GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT GL_RENDERBUFFER_EXT r>
swap [ GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT GL_RENDERBUFFER_EXT ] dip
glFramebufferRenderbufferEXT
] with-framebuffer ;
@ -244,10 +243,10 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
[ drop dup [ -+ ] bi@ ] 2keep ;
: (reflection-face) ( gadget face -- )
swap reflection-texture>> >r >r
GL_FRAMEBUFFER_EXT
GL_COLOR_ATTACHMENT0_EXT
r> r> 0 glFramebufferTexture2DEXT
swap reflection-texture>> [
GL_FRAMEBUFFER_EXT
GL_COLOR_ATTACHMENT0_EXT
] 2dip 0 glFramebufferTexture2DEXT
check-framebuffer ;
: (draw-reflection-texture) ( gadget -- )

View File

@ -6,7 +6,7 @@ IN: sudoku
SYMBOL: solutions
SYMBOL: board
: pair+ ( a b c d -- a+b c+d ) swapd + >r + r> ;
: pair+ ( a b c d -- a+b c+d ) swapd [ + ] 2bi@ ;
: row ( n -- row ) board get nth ;
: board> ( m n -- x ) row nth ;
@ -19,13 +19,13 @@ SYMBOL: board
: box-contains? ( n x y -- ? )
[ 3 /i 3 * ] bi@
9 [ >r 3dup r> cell-contains? ] contains?
>r 3drop r> ;
9 [ [ 3dup ] dip cell-contains? ] contains?
[ 3drop ] dip ;
DEFER: search
: assume ( n x y -- )
[ >board ] 2keep [ >r 1+ r> search ] 2keep f>board ;
[ >board ] 2keep [ [ 1+ ] dip search ] 2keep f>board ;
: attempt ( n x y -- )
{
@ -59,9 +59,9 @@ DEFER: search
: search ( x y -- )
{
{ [ over 9 = ] [ >r drop 0 r> 1+ search ] }
{ [ over 9 = ] [ [ drop 0 ] dip 1+ search ] }
{ [ over 0 = over 9 = and ] [ 2drop solution. ] }
{ [ 2dup board> ] [ >r 1+ r> search ] }
{ [ 2dup board> ] [ [ 1+ ] dip search ] }
[ solve ]
} cond ;

View File

@ -88,7 +88,7 @@ TUPLE: tetris
: tetris-move ( tetris move -- ? )
#! moves the piece if possible, returns whether the piece was moved
2dup can-move? [
>r current-piece r> move-piece drop t
[ current-piece ] dip move-piece drop t
] [
2drop f
] if ;

View File

@ -20,7 +20,7 @@ IN: tetris.gl
! TODO: move implementation specific stuff into tetris-board
: (draw-row) ( x y row -- )
>r over r> nth dup
[ over ] dip nth dup
[ gl-color 2array draw-block ] [ 3drop ] if ;
: draw-row ( y row -- )