steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-03-07 19:33:25 -06:00
parent c4862fc28f f9283bd0af
commit 97a44b44ac
19 changed files with 67 additions and 200 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/bitstreams/bitstreams-tests.factor
View File

@ -6,17 +6,17 @@ io.streams.byte-array ;
IN: bitstreams.tests
[ 1 t ]
[ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test
[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
[ 254 8 t ]
[ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test
[ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
[ 4095 12 t ]
[ B{ 255 255 } <string-reader> <bitstream-reader> 12 swap read-bits ] unit-test
[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
[ B{ 254 } ]
[
<string-writer> <bitstream-writer> 254 8 rot
binary <byte-writer> <bitstream-writer> 254 8 rot
[ write-bits ] keep stream>> >byte-array
] unit-test

13
basis/core-text/core-text-tests.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test core-text core-foundation
core-foundation.dictionaries destructors
arrays kernel generalizations math accessors
core-foundation.utilities
combinators hashtables colors ;
USING: tools.test core-text core-text.fonts core-foundation
core-foundation.dictionaries destructors arrays kernel generalizations
math accessors core-foundation.utilities combinators hashtables colors
colors.constants ;
IN: core-text.tests
: test-font ( name -- font )
@ -21,8 +20,8 @@ IN: core-text.tests
: test-typographic-bounds ( string font -- ? )
[
test-font &CFRelease white <CTLine> &CFRelease
line-typographic-bounds {
test-font &CFRelease tuck COLOR: white <CTLine> &CFRelease
compute-line-metrics {
[ width>> float? ]
[ ascent>> float? ]
[ descent>> float? ]

2
basis/io/encodings/big5/big5.factor
View File

@ -3,7 +3,7 @@
USING: io.encodings.iana io.encodings.euc ;
IN: io.encodings.big5
EUC: big5 "vocab:io/encodings/big5/CP950.txt"
EUC: big5 "vocab:io/encodings/big5/CP950.TXT"
big5 "Big5" register-encoding

2
basis/simple-flat-file/simple-flat-file-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Yun, Jonghyouk.
! See http://factorcode.org/license.txt for BSD license.
USING: simple-flat-file tools.test memoize ;
USING: simple-flat-file tools.test memoize assocs ;
IN: simple-flat-file.tests

2
basis/simple-flat-file/simple-flat-file.factor
View File

@ -7,7 +7,7 @@ IN: simple-flat-file
[ "#" split1 drop ] map harvest ;
: split-column ( line -- columns )
"\t" split 2 head ;
" \t" split harvest 2 head ;
: parse-hex ( s -- n )
2 short tail hex> ;

15
basis/simple-flat-file/test1.txt Normal file
View File

@ -0,0 +1,15 @@
#
# Name: cp949 to Unicode table (for testing, partial)
#
0x00 0x0000 #NULL
0x01 0x0001 #START OF HEADING
0x02 0x0002 #START OF TEXT
0x03 0x0003 #END OF TEXT
0x04 0x0004 #END OF TRANSMISSION
0x8253 0xAD2A #HANGUL SYLLABLE KIYEOK WAE PIEUPSIOS
0x8254 0xAD2B #HANGUL SYLLABLE KIYEOK WAE SIOS
0x8255 0xAD2E #HANGUL SYLLABLE KIYEOK WAE CIEUC
0x8256 0xAD2F #HANGUL SYLLABLE KIYEOK WAE CHIEUCH
0x8257 0xAD30 #HANGUL SYLLABLE KIYEOK WAE KHIEUKH
0x8258 0xAD31 #HANGUL SYLLABLE KIYEOK WAE THIEUTH
0x8259 0xAD32 #HANGUL SYLLABLE KIYEOK WAE PHIEUPH

22
basis/stack-checker/stack-checker-tests.factor
View File

@ -288,7 +288,7 @@ DEFER: bar
[ [ [ dup call ] dup call ] infer ]
[ inference-error? ] must-fail-with
: m dup call ; inline
: m ( q -- ) dup call ; inline
[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with
@ -296,13 +296,13 @@ DEFER: bar
[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with
: m'' [ dup curry ] ; inline
: m'' ( -- q ) [ dup curry ] ; inline
: m''' m'' call call ; inline
: m''' ( -- ) m'' call call ; inline
[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with
: m-if t over if ; inline
: m-if ( a b c -- ) t over if ; inline
[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with
@ -488,7 +488,7 @@ ERROR: custom-error ;
[ custom-error ] infer
] unit-test
: funny-throw throw ; inline
: funny-throw ( a -- * ) throw ; inline
[ T{ effect f 0 0 t } ] [
[ 3 funny-throw ] infer
@ -502,12 +502,8 @@ ERROR: custom-error ;
[ dup [ 3 throw ] dip ] infer
] unit-test
! This was a false trigger of the undecidable quotation
! recursion bug
{ 2 1 } [ find-last-sep ] must-infer-as
! Regression
: missing->r-check 1 load-locals ;
: missing->r-check ( a -- ) 1 load-locals ;
[ [ missing->r-check ] infer ] must-fail
@ -516,7 +512,7 @@ ERROR: custom-error ;
[ [ [ f dup ] [ ] while ] infer ] must-fail
: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive
[ [ erg's-inference-bug ] infer ] must-fail
@ -544,10 +540,10 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
[ [ inference-invalidation-d ] infer ] must-fail
: bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline
: bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive
[ [ bad-recursion-3 ] infer ] must-fail
: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline
: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive
[ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
: bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive

2
basis/tools/annotations/annotations-tests.factor
View File

@ -45,4 +45,4 @@ M: string blah-generic ;
{ string blah-generic } watch
[ ] [ "hi" blah-generic ] unit-test
[ "hi" ] [ "hi" blah-generic ] unit-test

4
basis/ui/tools/listener/listener-tests.factor
View File

@ -25,7 +25,7 @@ IN: ui.tools.listener.tests
! This should not throw an exception
[ ] [ "interactor" get evaluate-input ] unit-test
[ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
[ ] [ [ "interactor" get interactor-busy? ] [ yield ] while ] unit-test
[ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
@ -48,7 +48,7 @@ IN: ui.tools.listener.tests
[ ] [ "hi" "interactor" get set-editor-string ] unit-test
[ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
[ ] [ [ "interactor" get interactor-busy? ] [ yield ] while ] unit-test
[ ] [ "interactor" get evaluate-input ] unit-test

12
extra/4DNav/4DNav.factor
View File

@ -3,6 +3,7 @@
USING: kernel
namespaces
accessors
assocs
make
math
math.functions
@ -16,6 +17,7 @@ colors
colors.constants
prettyprint
vars
call
quotations
io
io.directories
@ -27,8 +29,6 @@ ui.gadgets.panes
ui.gadgets
ui.traverse
ui.gadgets.borders
ui.gadgets.handler
ui.gadgets.slate
ui.gadgets.frames
ui.gadgets.tracks
ui.gadgets.labels
@ -53,6 +53,7 @@ adsoda
adsoda.tools
;
QUALIFIED-WITH: ui.pens.solid s
QUALIFIED-WITH: ui.gadgets.wrappers w
IN: 4DNav
@ -392,6 +393,13 @@ USE: ui.gadgets.labeled.private
add-gadget
menu-quick-views add-gadget ;
TUPLE: handler < w:wrapper table ;
: <handler> ( child -- handler ) handler w:new-wrapper ;
M: handler handle-gesture ( gesture gadget -- ? )
tuck table>> at dup [ call( gadget -- ) f ] [ 2drop t ] if ;
: add-keyboard-delegate ( obj -- obj )
<handler>
{

5
extra/4DNav/file-chooser/file-chooser.factor
View File

@ -24,7 +24,6 @@ ui.gadgets.panes
ui.gadgets.scrollers
prettyprint
combinators
rewrite-closures
accessors
values
tools.walker
@ -67,7 +66,7 @@ file-chooser H{
[ directory? ] bi or ] filter
;
: update-filelist-model ( file-chooser -- file-chooser )
: update-filelist-model ( file-chooser -- )
[ list-of-files ] [ model>> ] bi set-model ;
: init-filelist-model ( file-chooser -- file-chooser )
@ -86,7 +85,7 @@ file-chooser H{
: fc-go-home ( file-chooser -- )
[ home ] (fc-go) ;
: fc-change-directory ( file-chooser file -- file-chooser )
: fc-change-directory ( file-chooser file -- )
dupd [ path>> value>> normalize-path ] [ name>> ] bi*
append-path over path>> set-model
update-filelist-model

4
extra/4DNav/turtle/turtle.factor
View File

@ -10,9 +10,9 @@ IN: 4DNav.turtle
VAR: self
: with-self ( quot obj -- ) [ >self call ] with-scope ;
: with-self ( quot obj -- ) [ >self call ] with-scope ; inline
: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ;
: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

16
extra/tetris/board/board-tests.factor
View File

@ -1,23 +1,23 @@
USING: accessors arrays colors kernel tetris.board tetris.piece tools.test ;
USING: accessors arrays colors colors.constants kernel tetris.board tetris.piece tools.test ;
[ { { f f } { f f } { f f } } ] [ 2 3 make-rows ] unit-test
[ { { f f } { f f } { f f } } ] [ 2 3 <board> rows>> ] unit-test
[ 1 { f f } ] [ 2 3 <board> { 1 1 } board@block ] unit-test
[ f ] [ 2 3 <board> { 1 1 } block ] unit-test
[ 2 3 <board> { 2 3 } block ] must-fail
red 1array [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } block ] unit-test
COLOR: red 1array [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } block ] unit-test
[ t ] [ 2 3 <board> { 1 1 } block-free? ] unit-test
[ f ] [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } block-free? ] unit-test
[ t ] [ 2 3 <board> dup { 1 1 } red set-block { 1 2 } block-free? ] unit-test
[ t ] [ 2 3 <board> dup { 1 1 } red set-block { 0 1 } block-free? ] unit-test
[ f ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } block-free? ] unit-test
[ t ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 2 } block-free? ] unit-test
[ t ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 0 1 } block-free? ] unit-test
[ t ] [ 2 3 <board> { 0 0 } block-in-bounds? ] unit-test
[ f ] [ 2 3 <board> { -1 0 } block-in-bounds? ] unit-test
[ t ] [ 2 3 <board> { 1 2 } block-in-bounds? ] unit-test
[ f ] [ 2 3 <board> { 2 2 } block-in-bounds? ] unit-test
[ t ] [ 2 3 <board> { 1 1 } location-valid? ] unit-test
[ f ] [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } location-valid? ] unit-test
[ f ] [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } location-valid? ] unit-test
[ t ] [ 10 10 <board> 10 <random-piece> piece-valid? ] unit-test
[ f ] [ 2 3 <board> 10 <random-piece> { 1 2 } >>location piece-valid? ] unit-test
[ { { f } { f } } ] [ 1 1 <board> add-row rows>> ] unit-test
[ { { f } } ] [ 1 2 <board> dup { 0 1 } red set-block remove-full-rows rows>> ] unit-test
[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } red set-block dup check-rows drop rows>> ] unit-test
[ { { f } } ] [ 1 2 <board> dup { 0 1 } COLOR: red set-block remove-full-rows rows>> ] unit-test
[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } COLOR: red set-block dup check-rows drop rows>> ] unit-test

1
extra/ui/gadgets/handler/authors.txt
View File

@ -1 +0,0 @@
Eduardo Cavazos

11
extra/ui/gadgets/handler/handler.factor
View File

@ -1,11 +0,0 @@
USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ;
IN: ui.gadgets.handler
TUPLE: handler < wrapper table ;
: <handler> ( child -- handler ) handler new-wrapper ;
M: handler handle-gesture ( gesture gadget -- ? )
tuck table>> at dup [ call f ] [ 2drop t ] if ;

10
extra/ui/gadgets/lists/lists.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math.vectors classes.tuple math.rectangles colors
kernel sequences models opengl math math.order namespaces
ui.commands ui.gestures ui.render ui.gadgets
ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs ;
kernel sequences models opengl math math.order namespaces call
ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels
ui.gadgets.scrollers ui.gadgets.presentations ui.gadgets.viewports
ui.gadgets.packs ;
IN: ui.gadgets.lists
TUPLE: list < pack index presenter color hook ;
@ -32,7 +32,7 @@ TUPLE: list < pack index presenter color hook ;
hook>> [ [ list? ] find-parent ] prepend ;
: <list-presentation> ( hook elt presenter -- gadget )
keep [ >label text-theme ] dip
[ call( elt -- obj ) ] [ drop ] 2bi [ >label text-theme ] dip
<presentation>
swap >>hook ; inline

1
extra/ui/gadgets/slate/authors.txt
View File

@ -1 +0,0 @@
Eduardo Cavazos

13
extra/ui/gadgets/slate/slate-docs.factor
View File

@ -1,13 +0,0 @@
! Copyright (C) 2009 Eduardo Cavazos
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax multiline ;
IN: ui.gadgets.slate
ARTICLE: "ui.gadgets.slate" "Slate gadget"
{ $description "A gadget with an 'action' slot which should be set to a callable."}
{ $heading "Example" }
{ $code <" USING: processing.shapes ui.gadgets.slate ui.gadgets.panes ;
[ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] <slate>
gadget."> } ;
ABOUT: "ui.gadgets.slate"

124
extra/ui/gadgets/slate/slate.factor
View File

@ -1,124 +0,0 @@
! Copyright (C) 2009 Eduardo Cavazos
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
IN: ui.gadgets.slate
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: slate < gadget action pdim graft ungraft ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: init-slate ( slate -- slate )
[ ] >>action
{ 200 200 } >>pdim
[ ] >>graft
[ ] >>ungraft ;
: <slate> ( action -- slate )
slate new
init-slate
swap >>action ;
M: slate pref-dim* ( slate -- dim ) pdim>> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: combinators arrays sequences math
opengl.gl ui.gadgets.worlds ;
: width ( rect -- w ) dim>> first ;
: height ( rect -- h ) dim>> second ;
: screen-y* ( gadget -- loc )
{
[ find-world height ]
[ screen-loc second ]
[ height ]
}
cleave
+ - ;
: screen-loc* ( gadget -- loc )
{
[ screen-loc first ]
[ screen-y* ]
}
cleave
2array ;
: setup-viewport ( gadget -- gadget )
dup
{
[ screen-loc* ]
[ dim>> ]
}
cleave
gl-viewport ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: default-coordinate-system ( gadget -- gadget )
dup
{
[ drop 0 ]
[ width 1 - ]
[ height 1 - ]
[ drop 0 ]
}
cleave
-1 1
glOrtho ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M: slate graft* ( slate -- ) graft>> call ;
M: slate ungraft* ( slate -- ) ungraft>> call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: establish-coordinate-system ( gadget -- gadget )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M: slate establish-coordinate-system ( slate -- slate )
default-coordinate-system ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: draw-slate ( slate -- slate )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M: slate draw-slate ( slate -- slate ) dup action>> call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M: slate draw-gadget* ( slate -- )
GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
establish-coordinate-system
GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
setup-viewport
draw-slate
GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
dup
find-world
! The world coordinate system is a little wacky:
dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
setup-viewport
drop
drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!