-IN: alarms.tests\r
USING: alarms alarms.private kernel calendar sequences\r
tools.test threads concurrency.count-downs ;\r
+IN: alarms.tests\r
\r
[ ] [\r
1 <count-down>\r
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar combinators generic init
-kernel math namespaces sequences heaps boxes threads
-quotations assocs math.order ;
+USING: accessors assocs boxes calendar
+combinators.short-circuit fry heaps init kernel math.order
+namespaces quotations threads ;
IN: alarms
TUPLE: alarm
ERROR: bad-alarm-frequency frequency ;
: check-alarm ( frequency/f -- frequency/f )
- dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ;
+ dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
: <alarm> ( quot time frequency -- alarm )
check-alarm <box> alarm boa ;
: register-alarm ( alarm -- )
- dup dup time>> alarms get-global heap-push*
- swap entry>> >box
+ [ dup time>> alarms get-global heap-push* ]
+ [ entry>> >box ] bi
notify-alarm-thread ;
: alarm-expired? ( alarm now -- ? )
[ time>> ] dip before=? ;
: reschedule-alarm ( alarm -- )
- dup [ swap interval>> time+ now max ] change-time register-alarm ;
+ dup '[ _ interval>> time+ now max ] change-time register-alarm ;
: call-alarm ( alarm -- )
[ entry>> box> drop ]
-IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc alien.strings io.encodings.utf8 ;
+IN: alien.c-types.tests
CONSTANT: xyz 123
! This overrides the fact that small structures are never returned
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
"complex-float" c-type t >>return-in-registers? drop
- >>
+>>
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.complex.functor ;
-IN: alien.complex.functor.tests
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.destructors ;
-IN: alien.destructors.tests
: (shuffle-map) ( return parameters -- ret par )
[
- fortran-ret-type>c-type length swap "void" = [ 1+ ] unless
+ fortran-ret-type>c-type length swap "void" = [ 1 + ] unless
letters swap head [ "ret" swap suffix ] map
] [
- [ fortran-arg-type>c-type nip length 1+ ] map letters swap zip
+ [ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
[ first2 letters swap head [ "" 2sequence ] with map ] map concat
] bi* ;
-IN: alien.libraries.tests
USING: alien.libraries alien.syntax tools.test kernel ;
+IN: alien.libraries.tests
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
[ ] [ "doesnotexist" dlopen dlclose ] unit-test
-[ "fdasfsf" dll-valid? drop ] must-fail
\ No newline at end of file
+[ "fdasfsf" dll-valid? drop ] must-fail
-IN: alien.structs.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc words vocabs namespaces layouts ;
+IN: alien.structs.tests
C-STRUCT: bar
{ "int" "x" }
";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ;
+ERROR: no-such-symbol name library ;
+
: address-of ( name library -- value )
- load-library dlsym [ "No such symbol" throw ] unless* ;
+ 2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
SYNTAX: &:
scan "c-library" get '[ _ _ address-of ] over push-all ;
[ 4 ] [
0 "There are Four Upper Case characters"
- [ LETTER? [ 1+ ] when ] each
+ [ LETTER? [ 1 + ] when ] each
] unit-test
[ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test
: write1-lines ( ch -- )
write1
column get [
- 1+ [ 76 = [ crlf ] when ]
+ 1 + [ 76 = [ crlf ] when ]
[ 76 mod column set ] bi
] when* ;
: encode-pad ( seq n -- )
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
- [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
+ [ 1 + ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
: decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
-IN: biassocs.tests
USING: biassocs assocs namespaces tools.test ;
+IN: biassocs.tests
<bihash> "h" set
[ "A" ] [ "a" "b" get at ] unit-test
-[ "a" ] [ "A" "b" get value-at ] unit-test
\ No newline at end of file
+[ "a" ] [ "A" "b" get value-at ] unit-test
-IN: binary-search.tests
USING: binary-search math.order vectors kernel tools.test ;
+IN: binary-search.tests
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
-[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
-[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
-[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
-[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
+[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
+[ f ] [ "hello" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ f ] [ "zebra" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
dup 0 = [
<bit-array>
] [
- [ log2 1+ <bit-array> 0 ] keep
+ [ log2 1 + <bit-array> 0 ] keep
[ dup 0 = ] [
[ pick underlying>> pick set-alien-unsigned-1 ] keep
- [ 1+ ] [ -8 shift ] bi*
+ [ 1 + ] [ -8 shift ] bi*
] until 2drop
] if ;
-IN: bit-sets.tests
USING: bit-sets tools.test bit-arrays ;
+IN: bit-sets.tests
[ ?{ t f t f t f } ] [
?{ t f f f t f }
-IN: bit-vectors.tests\r
USING: tools.test bit-vectors vectors sequences kernel math ;\r
+IN: bit-vectors.tests\r
\r
[ 0 ] [ 123 <bit-vector> length ] unit-test\r
\r
io.streams.byte-array ;
IN: bitstreams.tests
-
[ BIN: 1111111111 ]
[
B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
[ get-abp + ] [ set-abp ] bi ; inline
: (align) ( n m -- n' )
- [ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
+ [ /mod 0 > [ 1 + ] when ] [ * ] bi ; inline
: align ( n bitstream -- )
[ get-abp swap (align) ] [ set-abp ] bi ; inline
-IN: bootstrap.image.tests
USING: bootstrap.image bootstrap.image.private tools.test
kernel math ;
+IN: bootstrap.image.tests
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
-: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
+: bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
: bignum>seq ( n -- seq )
#! n is positive or zero.
: emit-bignum ( n -- )
dup dup 0 < [ neg ] when bignum>seq
- [ nip length 1+ emit-fixnum ]
+ [ nip length 1 + emit-fixnum ]
[ drop 0 < 1 0 ? emit ]
[ nip emit-seq ]
2tri ;
SYMBOL: upload-images-destination
: destination ( -- dest )
- upload-images-destination get
- "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
- or ;
+ upload-images-destination get
+ "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
+ or ;
: checksums ( -- temp ) "checksums.txt" temp-file ;
"math.ratios" require
"math.floats" require
-"math.complex" require
\ No newline at end of file
+"math.complex" require
-IN: boxes.tests\r
USING: boxes namespaces tools.test accessors ;\r
+IN: boxes.tests\r
\r
[ ] [ <box> "b" set ] unit-test\r
\r
[ blank? not ] filter
2 group [ hex> ] B{ } map-as
parsed ;
-
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test cache ;
-IN: cache.tests
: purge-cache ( cache -- )
dup max-age>> '[
- [ nip [ 1+ ] change-age age>> _ >= ] assoc-partition
+ [ nip [ 1 + ] change-age age>> _ >= ] assoc-partition
[ values dispose-each ] dip
- ] change-assoc drop ;
\ No newline at end of file
+ ] change-assoc drop ;
-IN: cairo.tests
USING: cairo tools.test math.rectangles accessors ;
+IN: cairo.tests
[ { 10 20 } ] [
{ 10 20 } [
{ 0 1 } { 3 4 } <rect> fill-rect
] make-bitmap-image dim>>
-] unit-test
\ No newline at end of file
+] unit-test
}
: month-name ( n -- string )
- check-month 1- month-names nth ;
+ check-month 1 - month-names nth ;
CONSTANT: month-abbreviations
{
}
: month-abbreviation ( n -- string )
- check-month 1- month-abbreviations nth ;
+ check-month 1 - month-abbreviations nth ;
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
100 b * d + 4800 -
m 10 /i + m 3 +
12 m 10 /i * -
- e 153 m * 2 + 5 /i - 1+ ;
+ e 153 m * 2 + 5 /i - 1 + ;
GENERIC: easter ( obj -- obj' )
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
: months/years ( n -- months years )
- 12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
+ 12 /rem dup zero? [ drop 1 - 12 ] when swap ; inline
M: integer +month ( timestamp n -- timestamp )
[ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
#! http://web.textfiles.com/computers/formulas.txt
#! good for any date since October 15, 1582
[
- dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
+ dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when
[ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
- [ 1+ 3 * 5 /i + ] keep 2 * +
- ] dip 1+ + 7 mod ;
+ [ 1 + 3 * 5 /i + ] keep 2 * +
+ ] dip 1 + + 7 mod ;
GENERIC: days-in-year ( obj -- n )
year leap-year? [
year month day <date>
year 3 1 <date>
- after=? [ 1+ ] when
+ after=? [ 1 + ] when
] when ;
: day-of-year ( timestamp -- n )
[ (days-in-month) day-abbreviations2 " " join print ] 2tri\r
over " " <repetition> concat write\r
[\r
- [ 1+ day. ] keep\r
- 1+ + 7 mod zero? [ nl ] [ bl ] if\r
+ [ 1 + day. ] keep\r
+ 1 + + 7 mod zero? [ nl ] [ bl ] if\r
] with each nl ;\r
\r
M: timestamp month. ( timestamp -- )\r
GENERIC: year. ( obj -- )\r
\r
M: integer year. ( n -- )\r
- 12 [ 1+ 2array month. nl ] with each ;\r
+ 12 [ 1 + 2array month. nl ] with each ;\r
\r
M: timestamp year. ( timestamp -- )\r
year>> year. ;\r
"," read-token day-abbreviations3 member? check-timestamp drop\r
read1 CHAR: \s assert=\r
read-sp checked-number >>day\r
- read-sp month-abbreviations index 1+ check-timestamp >>month\r
+ read-sp month-abbreviations index 1 + check-timestamp >>month\r
read-sp checked-number >>year\r
":" read-token checked-number >>hour\r
":" read-token checked-number >>minute\r
"," read-token check-day-name\r
read1 CHAR: \s assert=\r
"-" read-token checked-number >>day\r
- "-" read-token month-abbreviations index 1+ check-timestamp >>month\r
+ "-" read-token month-abbreviations index 1 + check-timestamp >>month\r
read-sp checked-number >>year\r
":" read-token checked-number >>hour\r
":" read-token checked-number >>minute\r
: (cookie-string>timestamp-2) ( -- timestamp )\r
timestamp new\r
read-sp check-day-name\r
- read-sp month-abbreviations index 1+ check-timestamp >>month\r
+ read-sp month-abbreviations index 1 + check-timestamp >>month\r
read-sp checked-number >>day\r
":" read-token checked-number >>hour\r
":" read-token checked-number >>minute\r
IN: channels.examples
: (counter) ( channel n -- )
- [ swap to ] 2keep 1+ (counter) ;
+ [ swap to ] 2keep 1 + (counter) ;
: counter ( channel -- )
2 (counter) ;
! Copyright (C) 2009 Alaric Snell-Pym
! See http://factorcode.org/license.txt for BSD license.
-
USING: checksums classes.singleton kernel math math.ranges
math.vectors sequences ;
-
IN: checksums.fnv1
SINGLETON: fnv1-32
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays checksums checksums.md5 io.encodings.binary
io.streams.byte-array kernel math namespaces tools.test ;
-
+IN: checksums.md5.tests
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test
! See http;//factorcode.org/license.txt for BSD license
USING: arrays kernel tools.test sequences sequences.private
circular strings ;
+IN: circular.tests
[ 0 ] [ { 0 1 2 3 4 } <circular> 0 swap virtual@ drop ] unit-test
[ 2 ] [ { 0 1 2 3 4 } <circular> 2 swap virtual@ drop ] unit-test
: push-growing-circular ( elt circular -- )
dup full? [ push-circular ]
- [ [ 1+ ] change-length set-last ] if ;
+ [ [ 1 + ] change-length set-last ] if ;
: <growing-circular> ( capacity -- growing-circular )
{ } new-sequence 0 0 growing-circular boa ;
! Copyright (C) 2005, 2006 Kevin Reid.
! See http://factorcode.org/license.txt for BSD license.
-IN: cocoa.callbacks
USING: assocs kernel namespaces cocoa cocoa.classes
cocoa.subclassing debugger ;
+IN: cocoa.callbacks
SYMBOL: callbacks
-IN: cocoa.tests
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory
compiler.units math core-graphics.types ;
+IN: cocoa.tests
CLASS: {
{ +superclass+ "NSObject" }
[ ] [ no-objc-type ] ?if ;
: (parse-objc-type) ( i string -- ctype )
- [ [ 1+ ] dip ] [ nth ] 2bi {
+ [ [ 1 + ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
-IN: cocoa.plists.tests
USING: tools.test cocoa.plists colors kernel hashtables
core-foundation.utilities core-foundation destructors
assocs cocoa.enumeration ;
+IN: cocoa.plists.tests
[
[ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
[ 3.5 ] [
3.5 >cf &CFRelease plist>
] unit-test
-] with-destructors
\ No newline at end of file
+] with-destructors
-IN: colors.hsv.tests
USING: accessors kernel colors colors.hsv tools.test math ;
+IN: colors.hsv.tests
: hsv>rgb ( h s v -- r g b )
[ 360 * ] 2dip
[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
-[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test
\ No newline at end of file
+[ 0.5 ] [ 180 0.1 0.2 0.5 <hsva> alpha>> ] unit-test
-IN: columns.tests
USING: columns sequences kernel namespaces arrays tools.test math ;
+IN: columns.tests
! Columns
{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
-
USING: kernel math tools.test combinators.short-circuit.smart ;
-
IN: combinators.short-circuit.smart.tests
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: must-be-t ( in -- ) [ t ] swap unit-test ;
-: must-be-f ( in -- ) [ f ] swap unit-test ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] must-be-t
-[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] must-be-t
-[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t
-
-[ { [ 1 ] [ f ] [ 3 ] } && 3 = ] must-be-f
-[ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] must-be-f
-[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t
+[ t ] [ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] unit-test
+[ t ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] unit-test
+[ t ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] unit-test
-[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] must-be-t
+[ f ] [ { [ 1 ] [ f ] [ 3 ] } && 3 = ] unit-test
+[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] unit-test
+[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] unit-test
-[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] must-be-t
+[ t ] [ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] unit-test
-[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f
+[ t ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] unit-test
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ t ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] unit-test
+[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] unit-test
-USING: kernel sequences math stack-checker effects accessors macros
-fry combinators.short-circuit ;
+USING: kernel sequences math stack-checker effects accessors
+macros fry combinators.short-circuit ;
IN: combinators.short-circuit.smart
<PRIVATE
+ERROR: cannot-determine-arity ;
+
: arity ( quots -- n )
first infer
- dup terminated?>> [ "Cannot determine arity" throw ] when
- effect-height neg 1+ ;
+ dup terminated?>> [ cannot-determine-arity ] when
+ effect-height neg 1 + ;
PRIVATE>
{ $example
<" USING: combinators combinators.smart math prettyprint ;
9 [
- { [ 1- ] [ 1+ ] [ sq ] } cleave
+ { [ 1 - ] [ 1 + ] [ sq ] } cleave
] output>array .">
"{ 8 10 81 }"
}
{ $examples
{ $example
"USING: combinators.smart kernel math prettyprint ;"
- "10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ."
+ "10 [ [ 1 - ] [ 1 + ] bi ] sum-outputs ."
"20"
}
} ;
IN: combinators.smart.tests
: test-bi ( -- 9 11 )
- 10 [ 1- ] [ 1+ ] bi ;
+ 10 [ 1 - ] [ 1 + ] bi ;
[ [ test-bi ] output>array ] must-infer
[ { 9 11 } ] [ [ test-bi ] output>array ] unit-test
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
-[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
\ No newline at end of file
+[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
+++ /dev/null
-IN: compiler.cfg.alias-analysis.tests
SYMBOL: ac-counter
: next-ac ( -- n )
- ac-counter [ dup 1+ ] change ;
+ ac-counter [ dup 1 + ] change ;
! Alias class for objects which are loaded from the data stack
! or other object slots. We pessimistically assume that they
eliminate-dead-stores ;
: alias-analysis ( cfg -- cfg' )
- [ alias-analysis-step ] local-optimization ;
\ No newline at end of file
+ [ alias-analysis-step ] local-optimization ;
-IN: compiler.cfg.builder.tests
USING: tools.test kernel sequences words sequences.private fry
prettyprint alien alien.accessors math.private compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
compiler.cfg arrays locals byte-arrays kernel.private math
slots.private vectors sbufs strings math.partial-dispatch
strings.private ;
+IN: compiler.cfg.builder.tests
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- )
compiler.cfg.debugger
compiler.cfg.instructions
compiler.cfg.registers ;
+IN: compiler.cfg.def-use.tests
V{
T{ ##peek f 0 D 0 }
-IN: compiler.cfg.dominance.tests
USING: tools.test sequences vectors namespaces kernel accessors assocs sets
math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger
compiler.cfg.predecessors ;
+IN: compiler.cfg.dominance.tests
: test-dominance ( -- )
cfg new 0 get >>entry
-IN: compiler.cfg.gc-checks.tests
USING: compiler.cfg.gc-checks compiler.cfg.debugger
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
namespaces accessors sequences ;
+IN: compiler.cfg.gc-checks.tests
: test-gc-checks ( -- )
H{ } clone representations set
[ ] [ test-gc-checks ] unit-test
-[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
\ No newline at end of file
+[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
IN: compiler.cfg.intrinsics.allot
: ##set-slots ( regs obj class -- )
- '[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ;
+ '[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ;
: emit-simple-allot ( node -- )
[ in-d>> length ] [ node-output-infos first class>> ] bi
- [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
+ [ drop ds-load ] [ [ 1 + cells ] dip ^^allot ] [ nip ] 2tri
[ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
: tuple-slot-regs ( layout -- vregs )
-IN: compiler.cfg.linear-scan.resolve.tests
USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces
accessors
compiler.cfg
compiler.cfg.instructions cpu.architecture make sequences
compiler.cfg.linear-scan.allocation.state ;
+IN: compiler.cfg.linear-scan.resolve.tests
[
{
T{ _reload { dst 0 } { rep int-rep } { n 8 } }
}
} member?
-] unit-test
\ No newline at end of file
+] unit-test
+++ /dev/null
-IN: compiler.cfg.linearization.tests
-USING: compiler.cfg.linearization tools.test ;
-
-
-IN: compiler.cfg.loop-detection.tests
USING: compiler.cfg compiler.cfg.loop-detection
compiler.cfg.predecessors
compiler.cfg.debugger
tools.test kernel namespaces accessors ;
+IN: compiler.cfg.loop-detection.tests
V{ } 0 test-bb
V{ } 1 test-bb
-IN: compiler.cfg.stacks.uninitialized.tests
USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
namespaces accessors sequences ;
+IN: compiler.cfg.stacks.uninitialized.tests
: test-uninitialized ( -- )
cfg new 0 get >>entry
-IN: compiler.cfg.two-operand.tests
USING: kernel compiler.cfg.two-operand compiler.cfg.instructions
compiler.cfg.registers cpu.architecture namespaces tools.test ;
+IN: compiler.cfg.two-operand.tests
3 vreg-counter set-global
-IN: compiler.codegen.tests
USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
compiler.constants ;
+IN: compiler.codegen.tests
[ ] [ [ ] with-fixup drop ] unit-test
[ ] [ [ \ + %call ] with-fixup drop ] unit-test
: callback-9 ( -- callback )
"int" { "int" "int" "int" } "cdecl" [
- + + 1+
+ + + 1 +
] alien-callback ;
FUNCTION: void ffi_test_36_point_5 ( ) ;
[ 123 ] [
"bool-field-test" <c-object> 123 over set-bool-field-test-parents
ffi_test_48
-] unit-test
\ No newline at end of file
+] unit-test
-IN: compiler.tests.call-effect
USING: tools.test combinators generic.single sequences kernel ;
+IN: compiler.tests.call-effect
: execute-ic-test ( a b -- c ) execute( a -- c ) ;
[ ] [ [ ] call-test ] unit-test
[ ] [ f [ drop ] curry call-test ] unit-test
[ ] [ [ ] [ ] compose call-test ] unit-test
-[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with
\ No newline at end of file
+[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with
-IN: compiler.tests.float
USING: compiler.units compiler kernel kernel.private memory math
math.private tools.test math.floats.private ;
+IN: compiler.tests.float
[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test
-IN: compiler.tests.generic
USING: tools.test math kernel compiler.units definitions ;
+IN: compiler.tests.generic
GENERIC: bad ( -- )
M: integer bad ;
[ 0 bad ] must-fail
[ "" bad ] must-fail
-[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
\ No newline at end of file
+[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
! regression
: branch-fold-regression-0 ( m -- n )
- t [ ] [ 1+ branch-fold-regression-0 ] if ; inline recursive
+ t [ ] [ 1 + branch-fold-regression-0 ] if ; inline recursive
: branch-fold-regression-1 ( -- m )
10 branch-fold-regression-0 ;
[ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test
-[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test
-[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1 + ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1 + ] compile-call ] unit-test
: deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
! Type inference issue
[ 4 3 ] [
1 >bignum 2 >bignum
- [ { bignum integer } declare [ shift ] keep 1+ ] compile-call
+ [ { bignum integer } declare [ shift ] keep 1 + ] compile-call
] unit-test
: broken-declaration ( -- ) \ + declare ;
\ bad-dispatch-position-test forget
\ bad-dispatch-position-test* forget
] with-compilation-unit
-] unit-test
\ No newline at end of file
+] unit-test
-IN: compiler.tests.peg-regression-2
USING: peg.ebnf strings tools.test ;
+IN: compiler.tests.peg-regression-2
GENERIC: <times> ( times -- term' )
M: string <times> ;
-IN: compiler.tests.pic-problem-1
USING: kernel sequences prettyprint memory tools.test ;
+IN: compiler.tests.pic-problem-1
TUPLE: x ;
CONSTANT: blah T{ x }
-[ T{ x } ] [ blah ] unit-test
\ No newline at end of file
+[ T{ x } ] [ blah ] unit-test
-IN: compiler.tests.redefine0
USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math
namespaces macros assocs ;
+IN: compiler.tests.redefine0
! Test ripple-up behavior
: test-1 ( -- a ) 3 ;
: word-3 ( a -- b ) 1 + ;
-: word-4 ( a -- b c ) 0 swap word-3 swap 1+ ;
+: word-4 ( a -- b c ) 0 swap word-3 swap 1 + ;
[ 1 1 ] [ 0 word-4 ] unit-test
-IN: compiler.tests.redefine16
USING: eval tools.test definitions words compiler.units
quotations stack-checker ;
+IN: compiler.tests.redefine16
[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
-IN: compiler.tests.redefine17
USING: tools.test classes.mixin compiler.units arrays kernel.private
strings sequences vocabs definitions kernel ;
+IN: compiler.tests.redefine17
<< "compiler.tests.redefine17" words forget-all >>
-IN: compiler.tests.redefine2
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs eval words.symbol ;
+IN: compiler.tests.redefine2
DEFER: redefine2-test
-IN: compiler.tests.redefine3
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval ;
+IN: compiler.tests.redefine3
GENERIC: sheeple ( obj -- x )
-IN: compiler.tests.redefine4
USING: io.streams.string kernel tools.test eval ;
+IN: compiler.tests.redefine4
: declaration-test-1 ( -- a ) 3 ; flushable
-IN: compiler.tests.reload
USE: vocabs.loader
+IN: compiler.tests.reload
! "parser" reload
! "sequences" reload
-IN: compiler.tests.stack-trace
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
words splitting grouping sorting accessors ;
+IN: compiler.tests.stack-trace
: symbolic-stack-trace ( -- newseq )
error-continuation get call>> callstack>array
-IN: compiler.tests.tuples
USING: kernel tools.test compiler.units compiler ;
+IN: compiler.tests.tuples
TUPLE: color red green blue ;
-IN: compiler.tree.builder.tests
USING: compiler.tree.builder tools.test sequences kernel
compiler.tree stack-checker stack-checker.errors ;
+IN: compiler.tree.builder.tests
: inline-recursive ( -- ) inline-recursive ; inline recursive
+++ /dev/null
-IN: compiler.tree.checker.tests
-USING: compiler.tree.checker tools.test ;
-
-
-IN: compiler.tree.cleanup.tests
USING: tools.test kernel.private kernel arrays sequences
math.private math generic words quotations alien alien.c-types
strings sbufs sequences.private slots.private combinators
compiler.tree.propagation.info
compiler.tree.checker
compiler.tree.debugger ;
+IN: compiler.tree.cleanup.tests
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
2over dup xyz drop >= [
3drop
] [
- [ swap [ call 1+ ] dip ] keep (i-repeat)
+ [ swap [ call 1 + ] dip ] keep (i-repeat)
] if ; inline recursive
: i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
[ 12 swap nth ] keep
14 ndrop
] cleaned-up-tree nodes>quot
-] unit-test
\ No newline at end of file
+] unit-test
-IN: compiler.tree.combinators.tests
USING: compiler.tree.combinators tools.test kernel ;
+IN: compiler.tree.combinators.tests
{ 1 0 } [ [ drop ] each-node ] must-infer-as
{ 1 1 } [ [ ] map-nodes ] must-infer-as
USING: sequences namespaces kernel accessors assocs sets fry
arrays combinators columns stack-checker.backend
stack-checker.branches compiler.tree compiler.tree.combinators
-compiler.tree.dead-code.liveness compiler.tree.dead-code.simple
-;
+compiler.tree.dead-code.liveness compiler.tree.dead-code.simple ;
IN: compiler.tree.dead-code.branches
M: #if mark-live-values* look-at-inputs ;
-IN: compiler.tree.debugger.tests
USING: compiler.tree.debugger tools.test sorting sequences io math.order ;
+IN: compiler.tree.debugger.tests
[ [ <=> ] sort ] optimized.
-[ <reversed> [ print ] each ] optimizer-report.
\ No newline at end of file
+[ <reversed> [ print ] each ] optimizer-report.
H{ } clone intrinsics-called set
0 swap [
- [ 1+ ] dip
+ [ 1 + ] dip
dup #call? [
word>> {
{ [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
-IN: compiler.tree.escape-analysis.check.tests
USING: compiler.tree.escape-analysis.check tools.test accessors kernel
kernel.private math compiler.tree.builder compiler.tree.normalization
compiler.tree.propagation compiler.tree.cleanup ;
+IN: compiler.tree.escape-analysis.check.tests
: test-checker ( quot -- ? )
build-tree normalize propagate cleanup run-escape-analysis? ;
[ f ] [
[ swap 1 2 ? ]
test-checker
-] unit-test
\ No newline at end of file
+] unit-test
-IN: compiler.tree.escape-analysis.tests
USING: compiler.tree.escape-analysis
compiler.tree.escape-analysis.allocations compiler.tree.builder
compiler.tree.recursive compiler.tree.normalization
compiler.tree.propagation.info stack-checker.errors
compiler.tree.checker
kernel.private vectors ;
+IN: compiler.tree.escape-analysis.tests
GENERIC: count-unboxed-allocations* ( m node -- n )
: (count-unboxed-allocations) ( m node -- n )
- out-d>> first escaping-allocation? [ 1+ ] unless ;
+ out-d>> first escaping-allocation? [ 1 + ] unless ;
M: #call count-unboxed-allocations*
dup immutable-tuple-boa?
[ (count-unboxed-allocations) ] [ drop ] if ;
M: #introduce count-unboxed-allocations*
- out-d>> [ escaping-allocation? [ 1+ ] unless ] each ;
+ out-d>> [ escaping-allocation? [ 1 + ] unless ] each ;
M: node count-unboxed-allocations* drop ;
dup i>> 1 <= [
drop 1 <ro-box>
] [
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
dup tuple-fib
swap
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
tuple-fib
swap i>> swap i>> + <ro-box>
] if ; inline recursive
[ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
: tuple-fib' ( m -- n )
- dup 1 <= [ 1- tuple-fib' i>> ] when <ro-box> ; inline recursive
+ dup 1 <= [ 1 - tuple-fib' i>> ] when <ro-box> ; inline recursive
[ 0 ] [ [ tuple-fib' ] count-unboxed-allocations ] unit-test
dup i>> 1 <= [
drop 1 <ro-box>
] [
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
dup bad-tuple-fib-1
swap
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
bad-tuple-fib-1 dup .
swap i>> swap i>> + <ro-box>
] if ; inline recursive
dup i>> 1 <= [
drop 1 <ro-box>
] [
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
dup bad-tuple-fib-2
swap
- i>> 1- <ro-box>
+ i>> 1 - <ro-box>
bad-tuple-fib-2
swap i>> swap i>> + <ro-box>
] if ; inline recursive
dup 1 <= [
drop 1 <ro-box>
] [
- 1- dup tuple-fib-2
+ 1 - dup tuple-fib-2
swap
- 1- tuple-fib-2
+ 1 - tuple-fib-2
swap i>> swap i>> + <ro-box>
] if ; inline recursive
dup 1 <= [
drop 1 <ro-box>
] [
- 1- dup tuple-fib-3
+ 1 - dup tuple-fib-3
swap
- 1- tuple-fib-3 dup .
+ 1 - tuple-fib-3 dup .
swap i>> swap i>> + <ro-box>
] if ; inline recursive
dup 1 <= [
drop 1 <ro-box>
] [
- 1- dup bad-tuple-fib-3
+ 1 - dup bad-tuple-fib-3
swap
- 1- bad-tuple-fib-3
+ 1 - bad-tuple-fib-3
2drop f
] if ; inline recursive
[ 0 ] [
[ { vector } declare length>> ]
count-unboxed-allocations
-] unit-test
\ No newline at end of file
+] unit-test
-IN: compiler.tree.escape-analysis.recursive.tests
USING: kernel tools.test namespaces sequences
compiler.tree.escape-analysis.recursive
compiler.tree.escape-analysis.allocations ;
+IN: compiler.tree.escape-analysis.recursive.tests
H{ } clone allocations set
<escaping-values> escaping-values set
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.modular-arithmetic.tests
USING: kernel kernel.private tools.test math math.partial-dispatch
math.private accessors slots.private sequences sequences.private strings sbufs
compiler.tree.builder
compiler.tree.normalization
compiler.tree.debugger
alien.accessors layouts combinators byte-arrays ;
+IN: compiler.tree.modular-arithmetic.tests
: test-modular-arithmetic ( quot -- quot' )
cleaned-up-tree nodes>quot ;
[ t ] [
[ 0 10 <byte-array> 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ]
{ >fixnum } inlined?
-] unit-test
\ No newline at end of file
+] unit-test
-IN: compiler.tree.normalization.tests
USING: compiler.tree.builder compiler.tree.recursive
compiler.tree.normalization
compiler.tree.normalization.introductions
compiler.tree.normalization.renaming
compiler.tree compiler.tree.checker
sequences accessors tools.test kernel math ;
+IN: compiler.tree.normalization.tests
[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
+++ /dev/null
-USING: compiler.tree.optimizer tools.test ;
-IN: compiler.tree.optimizer.tests
-
-
M: effect curry-effect
[ in>> length ] [ out>> length ] [ terminated?>> ] tri
- pick 0 = [ [ 1+ ] dip ] [ [ 1- ] 2dip ] if
+ pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
effect boa ;
M: curry cached-effect
-IN: compiler.tree.propagation.copy.tests
USING: compiler.tree.propagation.copy tools.test namespaces kernel
assocs ;
+IN: compiler.tree.propagation.copy.tests
H{ } clone copies set
SYMBOL: node-count
: count-nodes ( nodes -- n )
- 0 swap [ drop 1+ ] each-node ;
+ 0 swap [ drop 1 + ] each-node ;
: compute-node-count ( nodes -- ) count-nodes node-count set ;
dup name>> {
{
[ "alien-signed-" ?head ]
- [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
+ [ string>number 8 * 1 - 2^ dup neg swap 1 - [a,b] ]
}
{
[ "alien-unsigned-" ?head ]
- [ string>number 8 * 2^ 1- 0 swap [a,b] ]
+ [ string>number 8 * 2^ 1 - 0 swap [a,b] ]
}
} cond
[ fits-in-fixnum? fixnum integer ? ] keep <class/interval-info>
] unit-test
[ V{ fixnum } ] [
- [ >fixnum dup 100 < [ 1+ ] [ "Oops" throw ] if ] final-classes
+ [ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes
] unit-test
[ V{ -1 } ] [
- [ 0 dup 100 < not [ 1+ ] [ 1- ] if ] final-literals
+ [ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals
] unit-test
[ V{ 2 } ] [
] unit-test
: recursive-test-4 ( i n -- )
- 2dup < [ [ 1+ ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
+ 2dup < [ [ 1 + ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
[ ] [ [ recursive-test-4 ] final-info drop ] unit-test
[ V{ integer } ] [ [ { fixnum } declare recursive-test-6 ] final-classes ] unit-test
: recursive-test-7 ( a -- b )
- dup 10 < [ 1+ recursive-test-7 ] when ; inline recursive
+ dup 10 < [ 1 + recursive-test-7 ] when ; inline recursive
[ V{ fixnum } ] [ [ 0 recursive-test-7 ] final-classes ] unit-test
] unit-test
[ V{ bignum } ] [
- [ { bignum } declare dup 1- bitxor ] final-classes
+ [ { bignum } declare dup 1 - bitxor ] final-classes
] unit-test
[ V{ bignum integer } ] [
TUPLE: littledan-1 { a read-only } ;
-: (littledan-1-test) ( a -- ) a>> 1+ littledan-1 boa (littledan-1-test) ; inline recursive
+: (littledan-1-test) ( a -- ) a>> 1 + littledan-1 boa (littledan-1-test) ; inline recursive
: littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline
[ ] [ [ littledan-2-test ] final-classes drop ] unit-test
: (littledan-3-test) ( x -- )
- length 1+ f <array> (littledan-3-test) ; inline recursive
+ length 1
+ f <array> (littledan-3-test) ; inline recursive
: littledan-3-test ( -- )
0 f <array> (littledan-3-test) ; inline
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
-[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
+[ V{ 1 } ] [ [ { } length 1
+ f <array> length ] final-literals ] unit-test
! generalize-counter is not tight enough
[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times ] final-classes ] unit-test
-IN: compiler.tree.propagation.recursive.tests
USING: tools.test compiler.tree.propagation.recursive
math.intervals kernel math literals layouts ;
+IN: compiler.tree.propagation.recursive.tests
[ T{ interval f { 0 t } { 1/0. t } } ] [
T{ interval f { 1 t } { 1 t } }
{ [ over 0 = ] [ 2drop fixnum <class-info> ] }
{ [ 2dup length-accessor? ] [ nip length>> ] }
{ [ dup literal?>> ] [ literal>> literal-info-slot ] }
- [ [ 1- ] [ slots>> ] bi* ?nth ]
+ [ [ 1 - ] [ slots>> ] bi* ?nth ]
} cond [ object-info ] unless* ;
: rem-custom-inlining ( #call -- quot/f )
second value-info literal>> dup integer?
- [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
+ [ power-of-2? [ 1 - bitand ] f ? ] [ drop f ] if ;
{
mod-integer-integer
} 1&& ;
: lookup-table-seq ( assoc -- table )
- [ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
+ [ keys supremum 1 + ] keep '[ _ at ] { } map-as ;
: lookup-table-quot ( seq -- newquot )
lookup-table-seq
-IN: compiler.tree.recursive.tests
USING: tools.test kernel combinators.short-circuit math sequences accessors
compiler.tree
compiler.tree.builder
compiler.tree.combinators
compiler.tree.recursive
compiler.tree.recursive.private ;
+IN: compiler.tree.recursive.tests
[ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test
[ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test
] curry contains-node? ;
: loop-test-1 ( a -- )
- dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
+ dup [ 1 + loop-test-1 ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-1 ] build-tree analyze-recursive
] unit-test
: loop-test-2 ( a b -- a' )
- dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
+ dup [ 1+ loop-test-2 1 - ] [ drop ] if ; inline recursive
[ t ] [
[ loop-test-2 ] build-tree analyze-recursive
[ t ] [ [ b4 ] build-tree analyze-recursive \ a4 label-is-loop? ] unit-test
[ t ] [ [ b4 ] build-tree analyze-recursive \ b4 label-is-not-loop? ] unit-test
[ t ] [ [ a4 ] build-tree analyze-recursive \ a4 label-is-not-loop? ] unit-test
-[ t ] [ [ a4 ] build-tree analyze-recursive \ b4 label-is-loop? ] unit-test
\ No newline at end of file
+[ t ] [ [ a4 ] build-tree analyze-recursive \ b4 label-is-loop? ] unit-test
-IN: compiler.tree.tuple-unboxing.tests
USING: tools.test compiler.tree
compiler.tree.builder compiler.tree.recursive
compiler.tree.normalization compiler.tree.propagation
compiler.tree.def-use kernel accessors sequences math
math.private sorting math.order binary-search sequences.private
slots.private ;
+IN: compiler.tree.tuple-unboxing.tests
: test-unboxing ( quot -- )
build-tree
{ code } ;\r
\r
: <huffman-code> ( -- code ) 0 0 0 huffman-code boa ;\r
-: next-size ( code -- ) [ 1+ ] change-size [ 2 * ] change-code drop ;\r
-: next-code ( code -- ) [ 1+ ] change-code drop ;\r
+: next-size ( code -- ) [ 1 + ] change-size [ 2 * ] change-code drop ;\r
+: next-code ( code -- ) [ 1 + ] change-code drop ;\r
\r
:: all-patterns ( huff n -- seq )\r
n log2 huff size>> - :> free-bits\r
k swap - dup k! 0 >
]
[ ] produce swap suffix
- { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
+ { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1 + swap <repetition> append ] bi* ] [ suffix ] if ] reduce
[ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
}
: nth* ( n seq -- elt )
- [ length 1- swap - ] [ nth ] bi ;
+ [ length 1 - swap - ] [ nth ] bi ;
:: inflate-lz77 ( seq -- bytes )
1000 <byte-vector> :> bytes
seq
[
dup array?
- [ first2 '[ _ 1- bytes nth* bytes push ] times ]
+ [ first2 '[ _ 1 - bytes nth* bytes push ] times ]
[ bytes push ] if
] each
bytes ;
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors tools.test compression.lzw ;
-IN: compression.lzw.tests
-IN: concurrency.combinators.tests\r
USING: concurrency.combinators tools.test random kernel math \r
concurrency.mailboxes threads sequences accessors arrays\r
math.parser ;\r
+IN: concurrency.combinators.tests\r
\r
[ [ drop ] parallel-each ] must-infer\r
{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as\r
\r
[ "1a" "4b" "3c" ] [\r
2\r
- { [ 1- ] [ sq ] [ 1+ ] } parallel-cleave\r
+ { [ 1 - ] [ sq ] [ 1 + ] } parallel-cleave\r
[ number>string ] 3 parallel-napply\r
{ [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread\r
] unit-test\r
: count-down ( count-down -- )\r
dup n>> dup zero?\r
[ count-down-already-done ]\r
- [ 1- >>n count-down-check ] if ;\r
+ [ 1 - >>n count-down-check ] if ;\r
\r
: await-timeout ( count-down timeout -- )\r
[ promise>> ] dip ?promise-timeout ?linked t assert= ;\r
-IN: concurrency.distributed.tests
USING: tools.test concurrency.distributed kernel io.files
io.files.temp io.directories arrays io.sockets system
combinators threads math sequences concurrency.messaging
continuations accessors prettyprint ;
FROM: concurrency.messaging => receive send ;
+IN: concurrency.distributed.tests
: test-node ( -- addrspec )
{
-IN: concurrency.exchangers.tests\r
USING: tools.test concurrency.exchangers\r
concurrency.count-downs concurrency.promises locals kernel\r
threads ;\r
FROM: sequences => 3append ;\r
+IN: concurrency.exchangers.tests\r
\r
:: exchanger-test ( -- string )\r
[let |\r
-IN: concurrency.flags.tests\r
USING: tools.test concurrency.flags concurrency.combinators\r
kernel threads locals accessors calendar ;\r
+IN: concurrency.flags.tests\r
\r
:: flag-test-1 ( -- val )\r
[let | f [ <flag> ] |\r
-IN: concurrency.futures.tests\r
USING: concurrency.futures kernel tools.test threads ;\r
+IN: concurrency.futures.tests\r
\r
[ 50 ] [\r
[ 50 ] future ?future\r
-IN: concurrency.locks.tests\r
USING: tools.test concurrency.locks concurrency.count-downs\r
concurrency.messaging concurrency.mailboxes locals kernel\r
threads sequences calendar accessors ;\r
+IN: concurrency.locks.tests\r
\r
:: lock-test-0 ( -- v )\r
[let | v [ V{ } clone ]\r
<PRIVATE\r
\r
: add-reader ( lock -- )\r
- [ 1+ ] change-reader# drop ;\r
+ [ 1 + ] change-reader# drop ;\r
\r
: acquire-read-lock ( lock timeout -- )\r
over writer>>\r
writers>> notify-1 ;\r
\r
: remove-reader ( lock -- )\r
- [ 1- ] change-reader# drop ;\r
+ [ 1 - ] change-reader# drop ;\r
\r
: release-read-lock ( lock -- )\r
dup remove-reader\r
-IN: concurrency.mailboxes.tests\r
USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions\r
vectors sequences threads tools.test math kernel strings namespaces\r
continuations calendar destructors ;\r
+IN: concurrency.mailboxes.tests\r
\r
{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as\r
\r
[\r
<mailbox> 1 seconds mailbox-get-timeout\r
] [ wait-timeout? ] must-fail-with\r
-
\ No newline at end of file
+ \r
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-IN: concurrency.mailboxes\r
USING: dlists deques threads sequences continuations\r
destructors namespaces math quotations words kernel\r
arrays assocs init system concurrency.conditions accessors\r
debugger debugger.threads locals fry ;\r
+IN: concurrency.mailboxes\r
\r
TUPLE: mailbox threads data disposed ;\r
\r
-IN: concurrency.promises.tests\r
USING: vectors concurrency.promises kernel threads sequences\r
tools.test ;\r
+IN: concurrency.promises.tests\r
\r
[ V{ 50 50 50 } ] [\r
0 <vector>\r
: acquire-timeout ( semaphore timeout -- )\r
over count>> zero?\r
[ dupd wait-to-acquire ] [ drop ] if\r
- [ 1- ] change-count drop ;\r
+ [ 1 - ] change-count drop ;\r
\r
: acquire ( semaphore -- )\r
f acquire-timeout ;\r
\r
: release ( semaphore -- )\r
- [ 1+ ] change-count\r
+ [ 1 + ] change-count\r
threads>> notify-1 ;\r
\r
:: with-semaphore-timeout ( semaphore timeout quot -- )\r
-IN: cords.tests
USING: cords strings tools.test kernel sequences ;
+IN: cords.tests
[ "hello world" ] [ "hello" " world" cord-append dup like ] unit-test
[ "hello world" ] [ { "he" "llo" " world" } cord-concat dup like ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-foundation.numbers ;
-IN: core-foundation.numbers.tests
: (reset-timer) ( timer counter -- )
yield {
{ [ dup 0 = ] [ now ((reset-timer)) ] }
- { [ run-queue deque-empty? not ] [ 1- (reset-timer) ] }
+ { [ run-queue deque-empty? not ] [ 1 - (reset-timer) ] }
{ [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] }
[ sleep-queue heap-peek nip micros>timestamp ((reset-timer)) ]
} cond ;
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-foundation.utilities ;
-IN: core-foundation.utilities.tests
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-graphics.types ;
-IN: core-graphics.types.tests
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-text.fonts ;
-IN: core-text.fonts.tests
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test core-text.utilities ;
-IN: core-text.utilities.tests
-IN: cpu.ppc.assembler.tests
USING: cpu.ppc.assembler tools.test arrays kernel namespaces
make vocabs sequences ;
FROM: cpu.ppc.assembler => B ;
+IN: cpu.ppc.assembler.tests
: test-assembler ( expected quot -- )
[ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
! key = class\r
5 4 MR\r
! key &= cache.length - 1\r
- 5 5 mega-cache-size get 1- bootstrap-cell * ANDI\r
+ 5 5 mega-cache-size get 1 - bootstrap-cell * ANDI\r
! cache += array-start-offset\r
3 3 array-start-offset ADDI\r
! cache += key\r
temp dst 1 bignum@ STW
! Compute sign
temp src MR
- temp temp cell-bits 1- SRAWI
+ temp temp cell-bits 1 - SRAWI
temp temp 1 ANDI
! Store sign
temp dst 2 bignum@ STW
M: x86.64 %box-long-long ( n func -- )
[ int-rep ] dip %box ;
-: box-struct-field@ ( i -- operand ) 1+ cells param@ ;
+: box-struct-field@ ( i -- operand ) 1 + cells param@ ;
: %box-struct-field ( c-type i -- )
box-struct-field@ swap c-type-rep reg-class-of {
temp2 temp1 MOV
bootstrap-cell 8 = [ temp2 1 SHL ] when
! key &= cache.length - 1
- temp2 mega-cache-size get 1- bootstrap-cell * AND
+ temp2 mega-cache-size get 1 - bootstrap-cell * AND
! cache += array-start-offset
temp0 array-start-offset ADD
! cache += key
! make a copy
mod-arg div-arg MOV
! sign-extend
- mod-arg bootstrap-cell-bits 1- SAR
+ mod-arg bootstrap-cell-bits 1 - SAR
! divide
temp3 IDIV ;
-IN: cpu.x86.features.tests
USING: cpu.x86.features tools.test kernel sequences math system ;
+IN: cpu.x86.features.tests
cpu x86? [
[ t ] [ sse2? { t f } member? ] unit-test
[ t ] [ [ 10000 [ ] times ] count-instructions integer? ] unit-test
-] when
\ No newline at end of file
+] when
dst 3 bignum@ src MOV
! Compute sign
temp src MOV
- temp cell-bits 1- SAR
+ temp cell-bits 1 - SAR
temp 1 AND
! Store sign
dst 2 bignum@ temp MOV
M: random-id-generator eval-generator ( singleton -- obj )
drop
system-random-generator get [
- 63 [ random-bits ] keep 1- set-bit
+ 63 [ random-bits ] keep 1 - set-bit
] with-random ;
: interval-comparison ( ? str -- str )
} define-persistent
[ bignum-test drop-table ] ignore-errors
[ ] [ bignum-test ensure-table ] unit-test
- [ ] [ 63 2^ 1- dup dup <bignum-test> insert-tuple ] unit-test ;
+ [ ] [ 63 2^ 1 - dup dup <bignum-test> insert-tuple ] unit-test ;
! sqlite only
! [ T{ bignum-test f 1
-IN: debugger.tests\r
USING: debugger kernel continuations tools.test ;\r
+IN: debugger.tests\r
\r
[ ] [ [ drop ] [ error. ] recover ] unit-test\r
\r
[ f ] [ { } vm-error? ] unit-test\r
-[ f ] [ { "A" "B" } vm-error? ] unit-test
\ No newline at end of file
+[ f ] [ { "A" "B" } vm-error? ] unit-test\r
error-continuation get name>> assoc-stack ;
: :res ( n -- * )
- 1- restarts get-global nth f restarts set-global restart ;
+ 1 - restarts get-global nth f restarts set-global restart ;
: :1 ( -- * ) 1 :res ;
: :2 ( -- * ) 2 :res ;
: restart. ( restart n -- )
[
- 1+ dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
+ 1 + dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
name>> %
] "" make print ;
: array-size-error. ( obj -- )
"Invalid array size: " write dup third .
- "Maximum: " write fourth 1- . ;
+ "Maximum: " write fourth 1 - . ;
: c-string-error. ( obj -- )
"Cannot convert to C string: " write third . ;
"SIGUSR1" "SIGUSR2"
}
-: signal-name ( n -- str/f ) 1- signal-names ?nth ;
+: signal-name ( n -- str/f ) 1 - signal-names ?nth ;
: signal-name. ( n -- )
signal-name [ " (" ")" surround write ] when* ;
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test definitions.icons ;
-IN: definitions.icons.tests
TUPLE: hey value ;
C: <hey> hey
-CONSULT: alpha hey value>> 1+ ;
-CONSULT: beta hey value>> 1- ;
+CONSULT: alpha hey value>> 1 + ;
+CONSULT: beta hey value>> 1 - ;
[ 2 ] [ 1 <hey> one ] unit-test
[ 2 ] [ 1 <hey> two ] unit-test
-IN: disjoint-sets.testes
USING: tools.test disjoint-sets namespaces slots.private ;
+IN: disjoint-sets.testes
SYMBOL: +blah+
-405534154 +blah+ 1 set-slot
ranks>> at ; inline
: inc-rank ( a disjoint-set -- )
- ranks>> [ 1+ ] change-at ; inline
+ ranks>> [ 1 + ] change-at ; inline
: representative? ( a disjoint-set -- ? )
dupd parent = ; inline
-IN: documents.tests
USING: documents documents.private accessors sequences
namespaces tools.test make arrays kernel fry ;
+IN: documents.tests
! Tests
[ drop ] [ doc-line length ] 2bi 2array ;
: doc-lines ( from to document -- slice )
- [ 1+ ] [ value>> ] bi* <slice> ;
+ [ 1 + ] [ value>> ] bi* <slice> ;
: start-on-line ( from line# document -- n1 )
drop over first =
[ start-on-line ] [ end-on-line ] bi-curry bi-curry bi* ;
: last-line# ( document -- line )
- value>> length 1- ;
+ value>> length 1 - ;
CONSTANT: doc-start { 0 0 }
over length 1 = [
nip first2
] [
- first swap length 1- + 0
+ first swap length 1 - + 0
] if
] dip last length + 2array ;
0 swap [ append ] change-nth ;
: append-last ( str seq -- )
- [ length 1- ] keep [ prepend ] change-nth ;
+ [ length 1 - ] keep [ prepend ] change-nth ;
: loc-col/str ( loc document -- str col )
[ first2 swap ] dip nth swap ;
: (set-doc-range) ( doc-lines from to lines -- changed-lines )
[ prepare-insert ] 3keep
- [ [ first ] bi@ 1+ ] dip
+ [ [ first ] bi@ 1 + ] dip
replace-slice ;
: entire-doc ( document -- start end document )
: prev ( loc document quot: ( loc document -- loc ) -- loc )
{
{ [ pick { 0 0 } = ] [ 2drop ] }
- { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
+ { [ pick second zero? ] [ drop [ first 1 - ] dip line-end ] }
[ call ]
} cond ; inline
: next ( loc document quot: ( loc document -- loc ) -- loc )
{
{ [ 2over doc-end = ] [ 2drop ] }
- { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
+ { [ 2over line-end? ] [ 2drop first 1 + 0 2array ] }
[ call ]
} cond ; inline
M: one-word-elt prev-elt
drop
- [ [ 1- ] dip f prev-word ] modify-col ;
+ [ [ 1 - ] dip f prev-word ] modify-col ;
M: one-word-elt next-elt
drop
M: word-elt prev-elt
drop
- [ [ [ 1- ] dip blank-at? prev-word ] modify-col ]
+ [ [ [ 1 - ] dip blank-at? prev-word ] modify-col ]
prev ;
M: word-elt next-elt
USING: definitions io.launcher kernel math math.parser parser
namespaces prettyprint editors make ;
-
IN: editors.macvim
: macvim ( file line -- )
-IN: eval.tests
USING: eval tools.test ;
+IN: eval.tests
[ 4 ] [ "USE: math 2 2 +" eval( -- result ) ] unit-test
[ "USE: math 2 2 +" eval( -- ) ] must-fail
parse-paragraph paragraph boa ;
: cut-half-slice ( string i -- before after-slice )
- [ head ] [ 1+ short tail-slice ] 2bi ;
+ [ head ] [ 1 + short tail-slice ] 2bi ;
: find-cut ( string quot -- before after delimiter )
dupd find
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-
USING: calendar kernel formatting tools.test ;
-
IN: formatting.tests
[ "%s" printf ] must-infer
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-
USING: accessors arrays assocs calendar combinators fry kernel
generalizations io io.streams.string macros math math.functions
math.parser peg.ebnf quotations sequences splitting strings
unicode.categories unicode.case vectors combinators.smart ;
-
IN: formatting
<PRIVATE
: fix-sign ( string -- string )
dup CHAR: 0 swap index 0 =
[ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from
- [ dup 1- rot dup [ nth ] dip swap
+ [ dup 1 - rot dup [ nth ] dip swap
{
- { CHAR: - [ [ 1- ] dip remove-nth "-" prepend ] }
- { CHAR: + [ [ 1- ] dip remove-nth "+" prepend ] }
+ { CHAR: - [ [ 1 - ] dip remove-nth "-" prepend ] }
+ { CHAR: + [ [ 1 - ] dip remove-nth "+" prepend ] }
[ drop swap drop ]
} case
] [ drop ] if
abs 0 swap
[ dup [ 10.0 >= ] [ 1.0 < ] bi or ]
[ dup 10.0 >=
- [ 10.0 / [ 1+ ] dip ]
- [ 10.0 * [ 1- ] dip ] if
+ [ 10.0 / [ 1 + ] dip ]
+ [ 10.0 * [ 1 - ] dip ] if
] while
] keep 0 < [ neg ] when ;
-IN: fry.tests
USING: fry tools.test math prettyprint kernel io arrays
sequences eval accessors ;
+IN: fry.tests
[ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test
check-fry
[ [ deep-fry ] each ] [ ] make
[ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
- { _ } split [ spread>quot ] [ length 1- ] bi ;
+ { _ } split [ spread>quot ] [ length 1 - ] bi ;
PRIVATE>
-IN: functors.tests
USING: functors tools.test math words kernel multiline parser
io.streams.string generic ;
+IN: functors.tests
<<
+++ /dev/null
-USING: furnace.auth tools.test ;
-IN: furnace.auth.tests
-
+++ /dev/null
-IN: furnace.auth.features.edit-profile.tests
-USING: tools.test furnace.auth.features.edit-profile ;
-
-
+++ /dev/null
-IN: furnace.auth.features.recover-password
-USING: tools.test furnace.auth.features.recover-password ;
-
-
+++ /dev/null
-IN: furnace.auth.features.registration.tests
-USING: tools.test furnace.auth.features.registration ;
-
-
+++ /dev/null
-IN: furnace.auth.login.tests\r
-USING: tools.test furnace.auth.login ;\r
-\r
-\r
USING: accessors namespaces kernel combinators.short-circuit
db.tuples db.types furnace.auth furnace.sessions furnace.cache ;
-
IN: furnace.auth.login.permits
TUPLE: permit < server-state session uid ;
-IN: furnace.auth.providers.assoc.tests\r
USING: furnace.actions furnace.auth furnace.auth.providers \r
furnace.auth.providers.assoc furnace.auth.login\r
tools.test namespaces accessors kernel ;\r
+IN: furnace.auth.providers.assoc.tests\r
\r
<action> "Test" <login-realm>\r
<users-in-memory> >>users\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-IN: furnace.auth.providers.assoc\r
USING: accessors assocs kernel furnace.auth.providers ;\r
+IN: furnace.auth.providers.assoc\r
\r
TUPLE: users-in-memory assoc ;\r
\r
-IN: furnace.auth.providers.db.tests\r
USING: furnace.actions\r
furnace.auth\r
furnace.auth.login\r
furnace.auth.providers.db tools.test\r
namespaces db db.sqlite db.tuples continuations\r
io.files io.files.temp io.directories accessors kernel ;\r
+IN: furnace.auth.providers.db.tests\r
\r
<action> "test" <login-realm> realm set\r
\r
+++ /dev/null
-IN: furnace.db.tests
-USING: tools.test furnace.db ;
-
-
-IN: furnace.tests
USING: http http.server.dispatchers http.server.responses
http.server furnace furnace.utilities tools.test kernel
namespaces accessors io.streams.string urls xml.writer ;
+IN: furnace.tests
+
TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> ( -- dispatcher ) funny-dispatcher new-dispatcher ;
-IN: furnace.sessions.tests\r
USING: tools.test http furnace.sessions furnace.actions\r
http.server http.server.responses math namespaces make kernel\r
accessors io.sockets io.servers.connection prettyprint\r
io.streams.string io.files io.files.temp io.directories\r
splitting destructors sequences db db.tuples db.sqlite\r
continuations urls math.parser furnace furnace.utilities ;\r
+IN: furnace.sessions.tests\r
\r
: with-session ( session quot -- )\r
[\r
\r
M: foo call-responder*\r
2drop\r
- "x" [ 1+ ] schange\r
+ "x" [ 1 + ] schange\r
"x" sget number>string "text/html" <content> ;\r
\r
: url-responder-mock-test ( -- string )\r
\r
[ 9 ] [ "x" sget sq ] unit-test\r
\r
- [ ] [ "x" [ 1- ] schange ] unit-test\r
+ [ ] [ "x" [ 1 - ] schange ] unit-test\r
\r
[ 4 ] [ "x" sget sq ] unit-test\r
\r
+USING: ui game-input tools.test kernel system threads calendar
+combinators.short-circuit ;
IN: game-input.tests
-USING: ui game-input tools.test kernel system threads calendar ;
-os windows? os macosx? or [
+os { [ windows? ] [ macosx? ] } 1|| [
[ ] [ open-game-input ] unit-test
[ ] [ 1 seconds sleep ] unit-test
[ ] [ close-game-input ] unit-test
-] when
\ No newline at end of file
+] when
game-input-opened? [
(open-game-input)
] unless
- game-input-opened [ 1+ ] change-global
+ game-input-opened [ 1 + ] change-global
reset-mouse ;
: close-game-input ( -- )
game-input-opened [
dup zero? [ game-input-not-open ] when
- 1-
+ 1 -
] change-global
game-input-opened? [
(close-game-input)
IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
: record-button ( state hid-value element -- )
- [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ;
+ [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1 - ] tri* rot set-nth ;
: record-controller ( controller-state value -- )
dup IOHIDValueGetElement {
'[ _ { } nsequence ] ;
MACRO: nsum ( n -- )
- 1- [ + ] n*quot ;
+ 1 - [ + ] n*quot ;
MACRO: firstn-unsafe ( n -- )
[ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
- [ 1- swap bounds-check 2drop ]
+ [ 1 - swap bounds-check 2drop ]
[ firstn-unsafe ]
bi-curry '[ _ _ bi ]
] if ;
MACRO: npick ( n -- )
- 1- [ dup ] [ '[ _ dip swap ] ] repeat ;
+ 1 - [ dup ] [ '[ _ dip swap ] ] repeat ;
MACRO: nover ( n -- )
dup 1 + '[ _ npick ] n*quot ;
dup '[ _ npick ] n*quot ;
MACRO: nrot ( n -- )
- 1- [ ] [ '[ _ dip swap ] ] repeat ;
+ 1 - [ ] [ '[ _ dip swap ] ] repeat ;
MACRO: -nrot ( n -- )
- 1- [ ] [ '[ swap _ dip ] ] repeat ;
+ 1 - [ ] [ '[ swap _ dip ] ] repeat ;
MACRO: ndrop ( n -- )
[ drop ] n*quot ;
swap <repetition> spread>quot ;
MACRO: mnswap ( m n -- )
- 1+ '[ _ -nrot ] swap '[ _ _ napply ] ;
+ 1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
MACRO: nweave ( n -- )
[ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
-IN: globs.tests
USING: tools.test globs ;
+IN: globs.tests
[ f ] [ "abd" "fdf" glob-matches? ] unit-test
[ f ] [ "fdsafas" "?" glob-matches? ] unit-test
TUPLE: abstract-groups < chunking-seq ;
M: abstract-groups length
- [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
+ [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ;
M: abstract-groups set-length
[ n>> * ] [ seq>> ] bi set-length ;
TUPLE: abstract-clumps < chunking-seq ;
M: abstract-clumps length
- [ seq>> length ] [ n>> ] bi - 1+ ;
+ [ seq>> length ] [ n>> ] bi - 1 + ;
M: abstract-clumps set-length
- [ n>> + 1- ] [ seq>> ] bi set-length ;
+ [ n>> + 1 - ] [ seq>> ] bi set-length ;
M: abstract-clumps group@
[ n>> over + ] [ seq>> ] bi ;
: all-equal? ( seq -- ? ) [ = ] monotonic? ;
-: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
\ No newline at end of file
+: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
: right ( n -- m ) 1 shift 2 + ; inline
-: up ( n -- m ) 1- 2/ ; inline
+: up ( n -- m ) 1 - 2/ ; inline
: data-nth ( n heap -- entry )
data>> nth-unsafe ; inline
M: heap heap-delete ( entry heap -- )
[ entry>index ] keep
- 2dup heap-size 1- = [
+ 2dup heap-size 1 - = [
nip data-pop*
] [
[ nip data-pop ] 2keep
-IN: help.apropos.tests
USING: help.apropos tools.test ;
+IN: help.apropos.tests
[ ] [ "swp" apropos ] unit-test
-IN: help.crossref.tests
USING: help.crossref help.topics help.markup tools.test words
definitions assocs sequences kernel namespaces parser arrays
io.streams.string continuations debugger compiler.units eval ;
+IN: help.crossref.tests
[ ] [
"IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- )
-IN: help.handbook.tests
USING: help tools.test ;
+IN: help.handbook.tests
[ ] [ "article-index" print-topic ] unit-test
[ ] [ "primitive-index" print-topic ] unit-test
-IN: help.tests
USING: tools.test help kernel ;
+IN: help.tests
[ 3 throw ] must-fail
[ ] [ :help ] unit-test
-[ ] [ f print-topic ] unit-test
\ No newline at end of file
+[ ] [ f print-topic ] unit-test
-IN: help.html.tests
USING: help.html tools.test help.topics kernel ;
+IN: help.html.tests
[ ] [ "xml" >link help>html drop ] unit-test
-[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test
\ No newline at end of file
+[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test
-IN: help.vocabs.tests
USING: help.vocabs tools.test help.markup help vocabs ;
+IN: help.vocabs.tests
[ ] [ { $vocab "scratchpad" } print-content ] unit-test
-[ ] [ "classes" vocab print-topic ] unit-test
\ No newline at end of file
+[ ] [ "classes" vocab print-topic ] unit-test
-IN: html.components.tests
USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams
html.components html.forms namespaces
xml.writer ;
FROM: html.components => inspector ;
+IN: html.components.tests
[ ] [ begin-form ] unit-test
-IN: html.forms.tests
USING: kernel sequences tools.test assocs html.forms validators accessors
namespaces ;
FROM: html.forms => values ;
+IN: html.forms.tests
: with-validation ( quot -- messages )
[
[ value ] dip '[
[
form [ clone ] change
- 1+ "index" set-value
+ 1 + "index" set-value
"value" set-value
@
] with-scope
[ value ] dip '[
[
begin-form
- 1+ "index" set-value
+ 1 + "index" set-value
from-object
@
] with-scope
M: template-lexer skip-word
[
{
- { [ 2dup nth CHAR: " = ] [ drop 1+ ] }
+ { [ 2dup nth CHAR: " = ] [ drop 1 + ] }
{ [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
[ f skip ]
} cond
USING: http.client http.client.private http tools.test
namespaces urls ;
+IN: http.client.tests
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test http.client.post-data ;
-IN: http.client.post-data.tests
-IN: http.parsers.tests
USING: http http.parsers tools.test ;
+IN: http.parsers.tests
[ { } ] [ "" parse-cookie ] unit-test
[ { } ] [ "" parse-set-cookie ] unit-test
[ { T{ cookie { name "__s" } { value "12345567" } } } ]
[ "__s=12345567;" parse-cookie ]
-unit-test
\ No newline at end of file
+unit-test
-IN: http.server.redirection.tests
USING: http http.server.redirection urls accessors
namespaces tools.test present kernel ;
+IN: http.server.redirection.tests
[
<request>
-IN: http.server.static.tests
USING: http.server.static tools.test xml.writer ;
+IN: http.server.static.tests
-[ ] [ "resource:basis" directory>html write-xml ] unit-test
\ No newline at end of file
+[ ] [ "resource:basis" directory>html write-xml ] unit-test
] with each^2 ;
: sign-extend ( bits v -- v' )
- swap [ ] [ 1- 2^ < ] 2bi
- [ -1 swap shift 1+ + ] [ drop ] if ;
+ swap [ ] [ 1 - 2^ < ] 2bi
+ [ -1 swap shift 1 + + ] [ drop ] if ;
: read1-jpeg-dc ( decoder -- dc )
[ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
0 :> k!
[
color ac-huff-table>> read1-jpeg-ac
- [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
+ [ first 1 + k + k! ] [ second k coefs set-nth ] [ ] tri
{ 0 0 } = not
k 63 < and
] loop
[\r
alist sort-keys unclip swap [ [ first dup ] [ second ] bi ] dip\r
[| oldkey oldval key val | ! Underneath is start\r
- oldkey 1+ key =\r
+ oldkey 1 + key =\r
oldval val = and\r
[ oldkey 2array oldval 2array , key ] unless\r
key val\r
: something ( array -- num )
{
- { [ dup 1+ 2array ] [ 3 * ] }
+ { [ dup 1 + 2array ] [ 3 * ] }
{ [ 3array ] [ + + ] }
} switch ;
[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
-[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test
-[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] input<sequence ] undo ] unit-test
+[ 0 ] [ { 1 2 } [ [ 1 + 2 ] { } output>sequence ] undo ] unit-test
+[ { 0 1 } ] [ 1 2 [ [ [ 1 + ] bi@ ] input<sequence ] undo ] unit-test
dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
: num-fds ( mx -- n )
- [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
+ [ reads>> max-fd ] [ writes>> max-fd ] bi max 1 + ;
: init-fdsets ( mx -- nfds read write except )
[ num-fds ]
-IN: io.backend.windows.privileges.tests\r
USING: io.backend.windows.privileges tools.test ;\r
+IN: io.backend.windows.privileges.tests\r
\r
[ [ ] with-privileges ] must-infer\r
<PRIVATE
: encode-if< ( char stream encoding max -- )
- nip 1- pick < [ encode-error ] [ stream-write1 ] if ; inline
+ nip 1 - pick < [ encode-error ] [ stream-write1 ] if ; inline
: decode-if< ( stream encoding max -- character )
nip swap stream-read1 dup
128 encode-if< ;
M: ascii decode-char
- 128 decode-if< ;
\ No newline at end of file
+ 128 decode-if< ;
file-info ;
: volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
- MAX_PATH 1+ [ <byte-array> ] keep
+ MAX_PATH 1 + [ <byte-array> ] keep
"DWORD" <c-object>
"DWORD" <c-object>
"DWORD" <c-object>
- MAX_PATH 1+ [ <byte-array> ] keep
+ MAX_PATH 1 + [ <byte-array> ] keep
[ GetVolumeInformation win32-error=0/f ] 7 nkeep
drop 5 nrot drop
[ utf16n alien>string ] 4 ndip
] if ;
: find-first-volume ( -- string handle )
- MAX_PATH 1+ [ <byte-array> ] keep
+ MAX_PATH 1 + [ <byte-array> ] keep
dupd
FindFirstVolume dup win32-error=0/f
[ utf16n alien>string ] dip ;
: find-next-volume ( handle -- string/f )
- MAX_PATH 1+ [ <byte-array> tuck ] keep
+ MAX_PATH 1 + [ <byte-array> tuck ] keep
FindNextVolume 0 = [
GetLastError ERROR_NO_MORE_FILES =
[ drop f ] [ win32-error-string throw ] if
: (follow-links) ( n path -- path' )
over 0 = [ symlink-depth get too-many-symlinks ] when
dup link-info type>> +symbolic-link+ =
- [ [ 1- ] [ follow-link ] bi* (follow-links) ]
+ [ [ 1 - ] [ follow-link ] bi* (follow-links) ]
[ nip ] if ; inline recursive
PRIVATE>
IN: io.files.links.unix.tests
: make-test-links ( n path -- )
- [ '[ [ 1+ ] keep [ number>string _ prepend ] bi@ make-link ] each ]
+ [ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each ]
[ [ number>string ] dip prepend touch-file ] 2bi ; inline
[ t ] [
: count-trailing-backslashes ( str n -- str n )
[ "\\" ?tail ] dip swap [
- 1+ count-trailing-backslashes
+ 1 + count-trailing-backslashes
] when ;
: fix-trailing-backslashes ( str -- str' )
TUPLE: dummy-monitor < monitor ;
M: dummy-monitor dispose
- drop dummy-monitor-disposed get [ 1+ ] change-i drop ;
+ drop dummy-monitor-disposed get [ 1 + ] change-i drop ;
M: mock-io-backend (monitor)
nip
over exists? [
dummy-monitor new-monitor
- dummy-monitor-created get [ 1+ ] change-i drop
+ dummy-monitor-created get [ 1 + ] change-i drop
] [
"Does not exist" throw
] if ;
PRIVATE>
: run-pipeline ( seq -- results )
- [ length dup zero? [ drop { } ] [ 1- <pipes> ] if ] keep
+ [ length dup zero? [ drop { } ] [ 1
- <pipes> ] if ] keep
[
[ [ first in>> ] [ second out>> ] bi ] dip
run-pipeline-element
password [ B{ 0 } password! ] unless
[let | len [ password strlen ] |
- buf password len 1+ size min memcpy
+ buf password len 1 + size min memcpy
len
]
] alien-callback ;
\r
<PRIVATE\r
: levenshtein-step ( insert delete change same? -- next )\r
- 0 1 ? + [ [ 1+ ] bi@ ] dip min min ;\r
+ 0 1 ? + [ [ 1 + ] bi@ ] dip min min ;\r
\r
: lcs-step ( insert delete change same? -- next )\r
1 -1/0. ? + max max ; ! -1/0. is -inf (float)\r
\r
:: loop-step ( i j matrix old new step -- )\r
- i j 1+ matrix nth nth ! insertion\r
- i 1+ j matrix nth nth ! deletion\r
+ i j 1 + matrix nth nth ! insertion\r
+ i 1 + j matrix nth nth ! deletion\r
i j matrix nth nth ! replace/retain\r
i old nth j new nth = ! same?\r
step call\r
- i 1+ j 1+ matrix nth set-nth ; inline\r
+ i 1 + j 1 + matrix nth set-nth ; inline\r
\r
: lcs-initialize ( |str1| |str2| -- matrix )\r
[ drop 0 <array> ] with map ;\r
[ [ + ] curry map ] with map ;\r
\r
:: run-lcs ( old new init step -- matrix )\r
- [let | matrix [ old length 1+ new length 1+ init call ] |\r
+ [let | matrix [ old length 1 + new length 1 + init call ] |\r
old length [| i |\r
new length\r
[| j | i j matrix old new step loop-step ] each\r
TUPLE: trace-state old new table i j ;\r
\r
: old-nth ( state -- elt )\r
- [ i>> 1- ] [ old>> ] bi nth ;\r
+ [ i>> 1 - ] [ old>> ] bi nth ;\r
\r
: new-nth ( state -- elt )\r
- [ j>> 1- ] [ new>> ] bi nth ;\r
+ [ j>> 1 - ] [ new>> ] bi nth ;\r
\r
: top-beats-side? ( state -- ? )\r
- [ [ i>> ] [ j>> 1- ] [ table>> ] tri nth nth ]\r
- [ [ i>> 1- ] [ j>> ] [ table>> ] tri nth nth ] bi > ;\r
+ [ [ i>> ] [ j>> 1 - ] [ table>> ] tri nth nth ]\r
+ [ [ i>> 1 - ] [ j>> ] [ table>> ] tri nth nth ] bi > ;\r
\r
: retained? ( state -- ? )\r
{\r
\r
: do-retain ( state -- state )\r
dup old-nth retain boa ,\r
- [ 1- ] change-i [ 1- ] change-j ;\r
+ [ 1 - ] change-i [ 1 - ] change-j ;\r
\r
: inserted? ( state -- ? )\r
{\r
} 1&& ;\r
\r
: do-insert ( state -- state )\r
- dup new-nth insert boa , [ 1- ] change-j ;\r
+ dup new-nth insert boa , [ 1 - ] change-j ;\r
\r
: deleted? ( state -- ? )\r
{\r
} 1&& ;\r
\r
: do-delete ( state -- state )\r
- dup old-nth delete boa , [ 1- ] change-i ;\r
+ dup old-nth delete boa , [ 1 - ] change-i ;\r
\r
: (trace-diff) ( state -- )\r
{\r
} cond ;\r
\r
: trace-diff ( old new table -- diff )\r
- [ ] [ first length 1- ] [ length 1- ] tri trace-state boa\r
+ [ ] [ first length 1 - ] [ length 1 - ] tri trace-state boa\r
[ (trace-diff) ] { } make reverse ;\r
PRIVATE>\r
\r
{ 9 } [
<linked-hash>
- { [ 3 * ] [ 1- ] } "first" pick set-at
- { [ [ 1- ] bi@ ] [ 2 / ] } "second" pick set-at
+ { [ 3 * ] [ 1 - ] } "first" pick set-at
+ { [ [ 1 - ] bi@ ] [ 2 / ] } "second" pick set-at
4 6 pick values [ first call ] each
+ swap values <reversed> [ second call ] each
] unit-test
2 "by" pick set-at
3 "cx" pick set-at
>alist
-] unit-test
\ No newline at end of file
+] unit-test
cons>> car ;
M: lazy-take cdr ( lazy-take -- cdr )
- [ n>> 1- ] keep
+ [ n>> 1 - ] keep
cons>> cdr ltake ;
M: lazy-take nil? ( lazy-take -- ? )
C: lfrom-by lazy-from-by
: lfrom ( n -- list )
- [ 1+ ] lfrom-by ;
+ [ 1 + ] lfrom-by ;
M: lazy-from-by car ( lazy-from-by -- car )
n>> ;
[ index>> ] [ seq>> nth ] bi ;
M: sequence-cons cdr ( sequence-cons -- cdr )
- [ index>> 1+ ] [ seq>> sequence-tail>list ] bi ;
+ [ index>> 1 + ] [ seq>> sequence-tail>list ] bi ;
M: sequence-cons nil? ( sequence-cons -- ? )
drop f ;
] unit-test
{ T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [
- { 1 2 3 4 } sequence>list [ 1+ ] lmap
+ { 1 2 3 4 } sequence>list [ 1 + ] lmap
] unit-test
{ 15 } [
] if ; inline recursive
: llength ( list -- n )
- 0 [ drop 1+ ] foldl ;
+ 0 [ drop 1 + ] foldl ;
: lreverse ( list -- newlist )
nil [ swap cons ] foldl ;
IN: scratchpad
<< CONSTANT: five 5 >>
-{ $[ five dup 1+ dup 2 + ] } .
+{ $[ five dup 1 + dup 2 + ] } .
"> "{ 5 6 8 }" }
} ;
IN: scratchpad
CONSTANT: five 5
-{ $ five $[ five dup 1+ dup 2 + ] } .
+{ $ five $[ five dup 1 + dup 2 + ] } .
"> "{ 5 5 6 8 }" }
{ $subsection POSTPONE: $ }
{ $subsection POSTPONE: $[ }
{ $code
":: counter ( -- )"
" [let | value! [ 0 ] |"
- " [ value 1+ dup value! ]"
- " [ value 1- dup value! ] ] ;"
+ " [ value 1 + dup value! ]"
+ " [ value 1 - dup value! ] ] ;"
}
"Mutable bindings are implemented in a manner similar to the ML language; each mutable binding is actually an immutable binding of a mutable cell (in Factor's case, a 1-element array); reading the binding automatically dereferences the array, and writing to the binding stores into the array."
$nl
[ 5 ] [ 10 xyzzy ] unit-test
:: let*-test-1 ( a -- b )
- [let* | b [ a 1+ ]
- c [ b 1+ ] |
+ [let* | b [ a 1 + ]
+ c [ b 1 + ] |
a b c 3array ] ;
[ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test
:: let*-test-2 ( a -- b )
- [let* | b [ a 1+ ]
- c! [ b 1+ ] |
+ [let* | b [ a 1 + ]
+ c! [ b 1 + ] |
a b c 3array ] ;
[ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test
:: let*-test-3 ( a -- b )
- [let* | b [ a 1+ ]
- c! [ b 1+ ] |
- c 1+ c! a b c 3array ] ;
+ [let* | b [ a 1 + ]
+ c! [ b 1 + ] |
+ c 1 + c! a b c 3array ] ;
[ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
[ 3 ] [ 3 [| | :> a! a ] call ] unit-test
-[ 3 ] [ 2 [| | :> a! a 1+ a! a ] call ] unit-test
+[ 3 ] [ 2 [| | :> a! a 1 + a! a ] call ] unit-test
:: wlet-&&-test ( a -- ? )
[wlet | is-integer? [ a integer? ]
over exists? [ move-file ] [ 2drop ] if ;\r
\r
: advance-log ( path n -- )\r
- [ 1- log# ] 2keep log# ?move-file ;\r
+ [ 1 - log# ] 2keep log# ?move-file ;\r
\r
: rotate-log ( service -- )\r
dup close-log\r
INSTANCE: bits immutable-sequence
: unbits ( seq -- number )
- <reversed> 0 [ [ 1 shift ] dip [ 1+ ] when ] reduce ;
+ <reversed> 0 [ [ 1 shift ] dip [ 1 + ] when ] reduce ;
HELP: permutation
{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
-{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." }
+{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1 -" } "." }
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"1 3 permutation ." "{ 0 2 1 }" }
: do-row ( exchange-with row# -- )
[ exchange-rows ] keep
[ first-col ] keep
- dup 1+ rows-from clear-col ;
+ dup 1 + rows-from clear-col ;
: find-row ( row# quot -- i elt )
[ rows-from ] dip find ; inline
: (echelon) ( col# row# -- )
over cols < over rows < and [
- 2dup pivot-row [ over do-row 1+ ] when*
- [ 1+ ] dip (echelon)
+ 2dup pivot-row [ over do-row 1 + ] when*
+ [ 1 + ] dip (echelon)
] [
2drop
] if ;
: count-factor ( n d -- n' c )
[ 1 ] 2dip [ /i ] keep
- [ dupd /mod zero? ] curry [ nip [ 1+ ] dip ] while drop
+ [ dupd /mod zero? ] curry [ nip [ 1 + ] dip ] while drop
swap ;
: write-factor ( n d -- n' d' )
: totient ( n -- t )
{
{ [ dup 2 < ] [ drop 0 ] }
- [ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * ]
+ [ dup unique-factors [ 1 [ 1 - * ] reduce ] [ product ] bi / * ]
} cond ; foldable
: divisors ( n -- seq )
[ 3 ] [ 10/3 truncate ] unit-test
[ -3 ] [ -10/3 truncate ] unit-test
-[ -1/2 ] [ 1/2 1- ] unit-test
-[ 3/2 ] [ 1/2 1+ ] unit-test
+[ -1/2 ] [ 1/2 1 - ] unit-test
+[ 3/2 ] [ 1/2 1 + ] unit-test
[ 1.0 ] [ 0.5 1/2 + ] unit-test
[ 1.0 ] [ 1/2 0.5 + ] unit-test
[ 89 ] [ 10 fib ] unit-test
-[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval( -- ) ] must-fail
+[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1 + ] 4 ndip ;" eval( -- ) ] must-fail
MEMO: see-test ( a -- b ) reverse ;
dup bytes>> length 256 < [ fill-bytes ] when ;
: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
- dupd [ length ] bi@ 1- - short cut-slice swap ;
+ dupd [ length ] bi@ 1 - - short cut-slice swap ;
: dump-until-separator ( multipart -- multipart )
dup
\r
3 <model> "x" set\r
"x" get [ 2 * ] <arrow> dup "z" set\r
-[ 1+ ] <arrow> "y" set\r
+[ 1
+ ] <arrow> "y" set
\r [ ] [ "y" get activate-model ] unit-test\r
[ t ] [ "z" get "x" get connections>> memq? ] unit-test\r
[ 7 ] [ "y" get value>> ] unit-test\r
M: model model-activated drop ;
: ref-model ( model -- n )
- [ 1+ ] change-ref ref>> ;
+ [ 1 + ] change-ref ref>> ;
: unref-model ( model -- n )
- [ 1- ] change-ref ref>> ;
+ [ 1 - ] change-ref ref>> ;
: activate-model ( model -- )
dup ref-model 1 = [
\r
TUPLE: an-observer { i integer } ;\r
\r
-M: an-observer model-changed nip [ 1+ ] change-i drop ;\r
+M: an-observer model-changed nip [ 1 + ] change-i drop ;\r
\r
[ 1 0 ] [\r
[let* | m1 [ 1 <model> ]\r
o1 i>>\r
o2 i>>\r
]\r
-] unit-test
\ No newline at end of file
+] unit-test\r
: parse-multiline-string ( end-text -- str )
[
lexer get
- [ 1+ swap (parse-multiline-string) ]
+ [ 1 + swap (parse-multiline-string) ]
change-column drop
] "" make ;
: gl-function-number ( -- n )
+gl-function-number-counter+ get-global
- dup 1+ +gl-function-number-counter+ set-global ;
+ dup 1 + +gl-function-number-counter+ set-global ;
: gl-function-pointer ( names n -- funptr )
gl-function-context 2array dup +gl-function-pointers+ get-global at
dup zero? [
2drop epsilon
] [
- [ exactly-n ] [ 1- at-most-n ] 2bi 2choice
+ [ exactly-n ] [ 1 - at-most-n ] 2bi 2choice
] if ;
: at-least-n ( parser n -- parser' )
: next-id ( -- n )
#! Return the next unique id for a parser
id get-global [
- dup 1+ id set-global
+ dup 1 + id set-global
] [
1 id set-global 0
] if* ;
IN: persistent.hashtables.config
: radix-bits ( -- n ) << cell 4 = 4 5 ? parsed >> ; foldable
-: radix-mask ( -- n ) radix-bits 2^ 1- ; foldable
-: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1- ; inline
+: radix-mask ( -- n ) radix-bits 2^ 1 - ; foldable
+: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1 - ; inline
{
{ [ 2dup root>> eq? ] [ nip ] }
{ [ over not ] [ 2drop T{ persistent-hash } ] }
- [ count>> 1- persistent-hash boa ]
+ [ count>> 1 - persistent-hash boa ]
} cond ;
M: persistent-hash >alist [ root>> >alist% ] { } make ;
persistent.hashtables.nodes ;
IN: persistent.hashtables.nodes.bitmap
-: index ( bit bitmap -- n ) [ 1- ] dip bitand bit-count ; inline
+: index ( bit bitmap -- n ) [ 1 - ] dip bitand bit-count ; inline
M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry )
[let* | shift [ bitmap-node shift>> ]
[ 1array ] dip node boa ;
: 2node ( first second -- node )
- [ 2array ] [ drop level>> 1+ ] 2bi node boa ;
+ [ 2array ] [ drop level>> 1 + ] 2bi node boa ;
: new-child ( new-child node -- node' expansion/f )
dup full? [ tuck level>> 1node ] [ node-add f ] if ;
: new-last ( val seq -- seq' )
- [ length 1- ] keep new-nth ;
+ [ length 1 - ] keep new-nth ;
: node-set-last ( child node -- node' )
clone [ new-last ] change-children ;
clone
dup tail>> full?
[ ppush-new-tail ] [ ppush-tail ] if
- [ 1+ ] change-count ;
+ [ 1 + ] change-count ;
: node-set-nth ( val i node -- node' )
clone [ new-nth ] change-children ;
clone
dup tail>> children>> length 1 >
[ ppop-tail ] [ ppop-new-tail ] if
- ] dip 1- >>count
+ ] dip 1 - >>count
]
} case ;
] [
CHAR: y = [
over zero?
- [ 2drop t ] [ [ 1- ] dip consonant? not ] if
+ [ 2drop t ] [ [ 1 - ] dip consonant? not ] if
] [
2drop t
] if
: skip-vowels ( i str -- i str )
2dup bounds-check? [
- 2dup consonant? [ [ 1+ ] dip skip-vowels ] unless
+ 2dup consonant? [ [ 1 + ] dip skip-vowels ] unless
] when ;
: skip-consonants ( i str -- i str )
2dup bounds-check? [
- 2dup consonant? [ [ 1+ ] dip skip-consonants ] when
+ 2dup consonant? [ [ 1 + ] dip skip-consonants ] when
] when ;
: (consonant-seq) ( n i str -- n )
skip-vowels
2dup bounds-check? [
- [ 1+ ] [ 1+ ] [ ] tri* skip-consonants [ 1+ ] dip
+ [ 1 + ] [ 1 + ] [ ] tri* skip-consonants [ 1 + ] dip
(consonant-seq)
] [
2drop
over 1 < [
2drop f
] [
- 2dup nth [ over 1- over nth ] dip = [
+ 2dup nth [ over 1 - over nth ] dip = [
consonant?
] [
2drop f
{ [ "bl" ?tail ] [ "ble" append ] }
{ [ "iz" ?tail ] [ "ize" append ] }
{
- [ dup length 1- over double-consonant? ]
+ [ dup length 1 - over double-consonant? ]
[ dup "lsz" last-is? [ but-last-slice ] unless ]
}
{
: ll->l ( str -- newstr )
{
{ [ dup last CHAR: l = not ] [ ] }
- { [ dup length 1- over double-consonant? not ] [ ] }
+ { [ dup length 1 - over double-consonant? not ] [ ] }
{ [ dup consonant-seq 1 > ] [ but-last-slice ] }
[ ]
} cond ;
: remove-breakpoints ( quot pos -- quot' )
over quotation? [
- 1+ cut [ (remove-breakpoints) ] bi@
+ 1 + cut [ (remove-breakpoints) ] bi@
[ -> ] glue
] [
drop
] each
] with-row
] each
- ] tabular-output nl ;
\ No newline at end of file
+ ] tabular-output nl ;
line-limit? [
"..." write pprinter get return
] when
- pprinter get [ 1+ ] change-line-count drop
+ pprinter get [ 1 + ] change-line-count drop
nl do-indent
] if ;
TUPLE: text < section string ;
: <text> ( string style -- text )
- over length 1+ \ text new-section
+ over length 1 + \ text new-section
swap >>style
swap >>string ;
: group-flow ( seq -- newseq )
[
dup length [
- 2dup 1- swap ?nth prev set
- 2dup 1+ swap ?nth next set
+ 2dup 1 - swap ?nth prev set
+ 2dup 1 + swap ?nth next set
swap nth dup split-before dup , split-after
] with each
] { } make { t } split harvest ;
: take-some ( seqs -- seqs seq )
0 over [ length + dup 76 >= ] find drop nip
- [ 1- cut-slice swap ] [ f swap ] if* concat ;
+ [ 1 - cut-slice swap ] [ f swap ] if* concat ;
: divide-lines ( strings -- strings )
[ dup ] [ take-some ] produce nip ;
(>>i) ;
M: random-dummy random-32* ( obj -- r )
- [ dup 1+ ] change-i drop ;
+ [ dup 1 + ] change-i drop ;
: y ( n seq -- y )
[ nth-unsafe 31 mask-bit ]
- [ [ 1+ ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline
+ [ [ 1 + ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline
: mt[k] ( offset n seq -- )
[
[
seq>>
[ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ]
- [ [ m 1- ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ]
+ [ [ m 1 - ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ]
bi
] [ 0 >>i drop ] bi ; inline
: init-mt-formula ( i seq -- f(seq[i]) )
- dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ; inline
+ dupd nth dup -30 shift bitxor 1812433253 * + 1 + 32 bits ; inline
: init-mt-rest ( seq -- )
- n 1- swap '[
- _ [ init-mt-formula ] [ [ 1+ ] dip set-nth ] 2bi
+ n 1 - swap '[
+ _ [ init-mt-formula ] [ [ 1 + ] dip set-nth ] 2bi
] each ; inline
: init-mt-seq ( seed -- seq )
M: mersenne-twister random-32* ( mt -- r )
[ next-index ]
[ seq>> nth-unsafe mt-temper ]
- [ [ 1+ ] change-i drop ] tri ;
+ [ [ 1 + ] change-i drop ] tri ;
[
[ 32 random-bits ] with-system-random
<PRIVATE
: random-integer ( n -- n' )
- dup log2 7 + 8 /i 1+
+ dup log2 7 + 8 /i 1 +
[ random-bytes >byte-array byte-array>bignum ]
[ 3 shift 2^ ] bi / * >integer ;
: randomize ( seq -- seq )
dup length [ dup 1 > ]
- [ [ iota random ] [ 1- ] bi [ pick exchange ] keep ]
+ [ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ]
while drop ;
: delete-random ( seq -- elt )
: to-times ( term n -- ast )
dup zero?
[ 2drop epsilon ]
- [ dupd 1- to-times 2array <concatenation> <maybe> ]
+ [ dupd 1 - to-times 2array <concatenation> <maybe> ]
if ;
M: from-to <times>
drop [ { [ length = ] [ ?nth "\r\n" member? ] } 2|| ] ;
M: ^ question>quot
- drop [ { [ drop zero? ] [ [ 1- ] dip ?nth "\r\n" member? ] } 2|| ] ;
+ drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth "\r\n" member? ] } 2|| ] ;
M: $unix question>quot
drop [ { [ length = ] [ ?nth CHAR: \n = ] } 2|| ] ;
M: ^unix question>quot
- drop [ { [ drop zero? ] [ [ 1- ] dip ?nth CHAR: \n = ] } 2|| ] ;
+ drop [ { [ drop zero? ] [ [ 1 - ] dip ?nth CHAR: \n = ] } 2|| ] ;
M: word-break question>quot
drop [ word-break-at? ] ;
M: lookbehind question>quot ! Returns ( index string -- ? )
term>> <reversed-option>
ast>dfa dfa>reverse-shortest-word
- '[ [ 1- ] dip f _ execute ] ;
+ '[ [ 1 - ] dip f _ execute ] ;
: check-string ( string -- string )
! Make this configurable
:: (next-match) ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? )
i string regexp quot call dup [| j |
j i j
- reverse? [ swap [ 1+ ] bi@ ] when
+ reverse? [ swap [ 1 + ] bi@ ] when
string
] [ drop f f f f ] if ; inline
: search-range ( i string reverse? -- seq )
- [ drop dup 1+ -1 ] [ length 1 ] if range boa ; inline
+ [ drop dup 1 + -1 ] [ length 1 ] if range boa ; inline
:: next-match ( i string regexp quot: ( i string regexp -- j ) reverse? -- i start end ? )
f f f f
[ subseq ] map-matches ;
: count-matches ( string regexp -- n )
- [ 0 ] 2dip [ 3drop 1+ ] each-match ;
+ [ 0 ] 2dip [ 3drop 1 + ] each-match ;
<PRIVATE
dup skip-blank [
[ index-from ] 2keep
[ swapd subseq ]
- [ 2drop 1+ ] 3bi
+ [ 2drop 1 + ] 3bi
] change-lexer-column ;
: parse-noblank-token ( lexer -- str/f )
"prettyprint" vocab [
"regexp.prettyprint" require
-] when
\ No newline at end of file
+] when
M: complex-sequence length
seq>> length -1 shift ;
M: complex-sequence nth-unsafe
- complex@ [ nth-unsafe ] [ [ 1+ ] dip nth-unsafe ] 2bi rect> ;
+ complex@ [ nth-unsafe ] [ [ 1 + ] dip nth-unsafe ] 2bi rect> ;
M: complex-sequence set-nth-unsafe
complex@
[ [ real-part ] [ ] [ ] tri* set-nth-unsafe ]
- [ [ imaginary-part ] [ 1+ ] [ ] tri* set-nth-unsafe ] 3bi ;
+ [ [ imaginary-part ] [ 1 + ] [ ] tri* set-nth-unsafe ] 3bi ;
dup HEX: 7e <= [
HEX: 80 bitor write1
] [
- dup log2 8 /i 1+
+ dup log2 8 /i 1 +
dup HEX: 7f >= [
HEX: ff write1
dup serialize-cell
<PRIVATE
:: insert ( seq quot: ( elt -- elt' ) n -- )
n zero? [
- n n 1- [ seq nth quot call ] bi@ >= [
- n n 1- seq exchange
- seq quot n 1- insert
+ n n 1 - [ seq nth quot call ] bi@ >= [
+ n n 1 - seq exchange
+ seq quot n 1 - insert
] unless
] unless ; inline recursive
PRIVATE>
[ length ] [ ] [ <circular> 1 over change-circular-start ] tri
[ @ not [ , ] [ drop ] if ] 3each
] { } make
- dup empty? [ over length 1- prefix ] when -1 prefix 2 clump
+ dup empty? [ over length 1 - prefix ] when -1 prefix 2 clump
swap
] dip
- '[ first2 [ 1+ ] bi@ _ _ boa ] map ; inline
+ '[ first2 [ 1 + ] bi@ _ _ boa ] map ; inline
PRIVATE>
: infer-<tuple-boa> ( -- )
\ <tuple-boa>
- peek-d literal value>> second 1+ { tuple } <effect>
+ peek-d literal value>> second 1 + { tuple } <effect>
apply-word/effect ;
\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
: from-to ( index begin suffix-array -- from/f to/f )
swap '[ _ head? not ]
- [ find-last-from drop dup [ 1+ ] when ]
+ [ find-last-from drop dup [ 1 + ] when ]
[ find-from drop ] 3bi ;
: <funky-slice> ( from/f to/f seq -- slice )
! erg's bug
GENERIC: some-generic ( a -- b )
-M: integer some-generic 1+ ;
+M: integer some-generic 1 + ;
[ 4 ] [ 3 some-generic ] unit-test
[ 4 ] [ 3 some-generic ] unit-test
-[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval( -- ) ] unit-test
+[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1 - ;" eval( -- ) ] unit-test
[ 2 ] [ 3 some-generic ] unit-test
: some-code ( -- )
f my-generic drop ;
-[ ] [ some-code ] unit-test
\ No newline at end of file
+[ ] [ some-code ] unit-test
:: (fuzzy) ( accum i full ch -- accum i full ? )
ch i full index-from [
:> i i accum push
- accum i 1+ full t
+ accum i 1 + full t
] [
f -1 full f
] if* ;
[
2dup number=
[ drop ] [ nip V{ } clone pick push ] if
- 1+
+ 1 +
] keep pick last push
] each ;
: score-1 ( i full -- n )
{
{ [ over zero? ] [ 2drop 10 ] }
- { [ 2dup length 1- number= ] [ 2drop 4 ] }
- { [ 2dup [ 1- ] dip nth Letter? not ] [ 2drop 10 ] }
- { [ 2dup [ 1+ ] dip nth Letter? not ] [ 2drop 4 ] }
+ { [ 2dup length 1 - number= ] [ 2drop 4 ] }
+ { [ 2dup [ 1 - ] dip nth Letter? not ] [ 2drop 10 ] }
+ { [ 2dup [ 1 + ] dip nth Letter? not ] [ 2drop 4 ] }
[ 2drop 1 ]
} cond ;
lf>crlf [
utf16n string>alien
EmptyClipboard win32-error=0/f
- GMEM_MOVEABLE over length 1+ GlobalAlloc
+ GMEM_MOVEABLE over length 1 + GlobalAlloc
dup win32-error=0/f
dup GlobalLock dup win32-error=0/f
<PRIVATE
-: page-elt ( editor -- editor element ) dup visible-lines 1- <page-elt> ;
+: page-elt ( editor -- editor element ) dup visible-lines 1
- <page-elt> ;
PRIVATE>
: this-line-and-next ( document line -- start end )
[ nip 0 swap 2array ]
- [ [ nip 1+ ] [ 1+ swap doc-line length ] 2bi 2array ]
+ [ [ nip 1 + ] [ 1 + swap doc-line length ] 2bi 2array ]
2bi ;
: last-line? ( document line -- ? )
[ '[ [ dim>> ] [ gap>> ] [ filled-cell>> ] tri _ tri@ ] dip ] dip call ; inline
: available-space ( pref-dim gap dims -- avail )
- length 1+ * [-] ; inline
+ length 1 + * [-] ; inline
: -center) ( pref-dim gap filled-cell dims -- )
[ nip available-space ] 2keep [ remove-nth sum [-] ] 2keep set-nth ; inline
[ <frame-grid> ] dip new-grid ; inline
: <frame> ( cols rows -- frame )
- frame new-frame ;
\ No newline at end of file
+ frame new-frame ;
mock-gadget new 0 >>graft-called 0 >>ungraft-called ;
M: mock-gadget graft*
- [ 1+ ] change-graft-called drop ;
+ [ 1 + ] change-graft-called drop ;
M: mock-gadget ungraft*
- [ 1+ ] change-ungraft-called drop ;
+ [ 1 + ] change-ungraft-called drop ;
! We can't print to output-stream here because that might be a pane
! stream, and our graft-queue rebinding here would be captured
3 [
<mock-gadget> over <model> >>model
"g" get over add-gadget drop
- swap 1+ number>string set
+ swap 1 + number>string set
] each ;
: status-flags ( -- seq )
USING: vocabs vocabs.loader ;
-"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when
\ No newline at end of file
+"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when
: line>y ( n gadget -- y ) line-height * >integer ;
: validate-line ( m gadget -- n )
- control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
+ control-value [ drop f ] [ length 1 - min 0 max ] if-empty ;
: valid-line? ( n gadget -- ? )
- control-value length 1- 0 swap between? ;
+ control-value length 1 - 0 swap between? ;
: visible-line ( gadget quot -- n )
'[
[ loc>> ] visible-line ;
: last-visible-line ( gadget -- n )
- [ [ loc>> ] [ dim>> ] bi v+ ] visible-line 1+ ;
+ [ [ loc>> ] [ dim>> ] bi v+ ] visible-line 1 + ;
: each-slice-index ( from to seq quot -- )
[ [ <slice> ] [ drop [a,b) ] 3bi ] dip 2each ; inline
2bi 2array ;
: visible-lines ( gadget -- n )
- [ visible-dim second ] [ line-height ] bi /i ;
\ No newline at end of file
+ [ visible-dim second ] [ line-height ] bi /i ;
0 select-row ;
: last-row ( table -- )
- dup control-value length 1- select-row ;
+ dup control-value length 1 - select-row ;
: prev/next-page ( table n -- )
- over visible-lines 1- * prev/next-row ;
+ over visible-lines 1 - * prev/next-row ;
: previous-page ( table -- )
-1 prev/next-page ;
dup renderer>> column-titles
[ <column-headers> ] [ drop f ] if ;
-PRIVATE>
\ No newline at end of file
+PRIVATE>
:: gradient-vertices ( direction dim colors -- seq )
direction dim v* dim over v- swap
- colors length dup 1- v/n [ v*n ] with map
+ colors length dup 1 - v/n [ v*n ] with map
swap [ over v+ 2array ] curry map
concat concat >float-array ;
[ colors>> draw-gradient ]
} cleave ;
-M: gradient pen-background 2drop transparent ;
\ No newline at end of file
+M: gradient pen-background 2drop transparent ;
\r
M: uniscribe-renderer x>offset ( x font string -- n )\r
[ 2drop 0 ] [\r
- cached-script-string x>line-offset 0 = [ 1+ ] unless\r
+ cached-script-string x>line-offset 0 = [ 1 + ] unless\r
] if-empty ;\r
\r
M: uniscribe-renderer offset>x ( n font string -- x )\r
V{ } clone 0 history boa ;
: history-add ( history -- input )
- dup elements>> length 1+ >>index
+ dup elements>> length 1 + >>index
[ document>> doc-string [ <input> ] [ empty? ] bi ] keep
'[ [ _ elements>> push ] keep ] unless ;
[ set-doc-string ] [ clear-undo drop ] 2bi ;
: change-history-index ( history i -- )
- over elements>> length 1-
+ over elements>> length 1 -
'[ _ + _ min 0 max ] change-index drop ;
: history-recall ( history i -- )
M: interactor dispose drop ;
: go-to-error ( interactor error -- )
- [ line>> 1- ] [ column>> ] bi 2array
+ [ line>> 1 - ] [ column>> ] bi 2array
over set-caret
mark>caret ;
[ call-next-method ] [ restart-listener ] bi ;
M: listener-gadget ungraft*
- [ com-end ] [ call-next-method ] bi ;
\ No newline at end of file
+ [ com-end ] [ call-next-method ] bi ;
] [
[
[ traverse-step traverse-from-path ]
- [ tuck children>> swap first 1+ tail-slice % ] 2bi
+ [ tuck children>> swap first 1 + tail-slice % ] 2bi
] make-node
] if
] if ;
traverse-step traverse-from-path ;
: (traverse-middle) ( frompath topath gadget -- )
- [ first 1+ ] [ first ] [ children>> ] tri* <slice> % ;
+ [ first 1 + ] [ first ] [ children>> ] tri* <slice> % ;
: traverse-post ( topath gadget -- )
traverse-step traverse-to-path ;
M: gadget leaves* conjoin ;
-: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ;
\ No newline at end of file
+: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ;
#! etc.
swap 2array windows get-global push
windows get-global dup length 1 >
- [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
+ [ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ;
: unregister-window ( handle -- )
windows [ [ first = not ] with filter ] change-global ;
: first-grapheme ( str -- i )
unclip-slice grapheme-class over
[ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop
- nip swap length or 1+ ;
+ nip swap length or 1 + ;
: first-grapheme-from ( start str -- i )
over tail-slice first-grapheme + ;
swap [ format/extended? not ] find-from drop ;
: walk-up ( str i -- j )
- dupd 1+ (walk-up) [ 1+ (walk-up) ] [ drop f ] if* ;
+ dupd 1 + (walk-up) [ 1 + (walk-up) ] [ drop f ] if* ;
: (walk-down) ( str i -- j )
swap [ format/extended? not ] find-last-from drop ;
: walk-down ( str i -- j )
- dupd (walk-down) [ 1- (walk-down) ] [ drop f ] if* ;
+ dupd (walk-down) [ 1 - (walk-down) ] [ drop f ] if* ;
: word-break? ( str i table-entry -- ? )
{
: first-word ( str -- i )
[ unclip-slice word-break-prop over <enum> ] keep
'[ swap _ word-break-next ] assoc-find 2drop
- nip swap length or 1+ ;
+ nip swap length or 1 + ;
: >words ( str -- words )
[ first-word ] >pieces ;
<PRIVATE
: nth-next ( i str -- str[i-1] str[i] )
- [ [ 1- ] keep ] dip '[ _ nth ] bi@ ;
+ [ [ 1 - ] keep ] dip '[ _ nth ] bi@ ;
PRIVATE>
:: assert= ( test spec quot -- )
spec [
[
- [ 1- test nth ] bi@
+ [ 1 - test nth ] bi@
[ 1quotation ] [ quot curry ] bi* unit-test
] with each
] assoc-each ;
! Normalization -- Composition
: initial-medial? ( str i -- ? )
- { [ swap nth initial? ] [ 1+ swap ?nth medial? ] } 2&& ;
+ { [ swap nth initial? ] [ 1 + swap ?nth medial? ] } 2&& ;
: --final? ( str i -- ? )
2 + swap ?nth final? ;
: compose-jamo ( str i -- str i )
2dup initial-medial? [
2dup --final? [ imf, ] [ im, ] if
- ] [ 2dup swap nth , 1+ ] if ;
+ ] [ 2dup swap nth , 1 + ] if ;
: pass-combining ( str -- str i )
dup [ non-starter? not ] find drop
: get-str ( state i -- ch )
swap [ i>> + ] [ str>> ] bi ?nth ; inline
: current ( state -- ch ) 0 get-str ; inline
-: to ( state -- state ) [ 1+ ] change-i ; inline
+: to ( state -- state ) [ 1 + ] change-i ; inline
: push-after ( ch state -- state ) [ ?push ] change-after ; inline
:: try-compose ( state new-char current-class -- state )
:: (compose) ( str i -- )
i str ?nth [
dup jamo? [ drop str i compose-jamo ] [
- i 1+ str ?nth combining-class
- [ str i 1+ compose-combining ] [ , str i 1+ ] if
+ i 1 + str ?nth combining-class
+ [ str i 1 + compose-combining ] [ , str i 1 + ] if
] if (compose)
] when* ; inline recursive
#! first group is -1337, legacy unix code
-1337 NGROUPS_MAX [ 4 * <byte-array> ] keep
<int> [ getgrouplist io-error ] 2keep
- [ 4 tail-slice ] [ *int 1- ] bi* >groups ;
+ [ 4 tail-slice ] [ *int 1 - ] bi* >groups ;
PRIVATE>
HEX: ff00 bitand -8 shift ; inline
: WIFSIGNALED ( status -- ? )
- HEX: 7f bitand 1+ -1 shift 0 > ; inline
+ HEX: 7f bitand 1 + -1 shift 0 > ; inline
: WCOREFLAG ( -- value )
HEX: 80 ; inline
: <front-node> ( elt front -- node )
[
unroll-factor 0 <array>
- [ unroll-factor 1- swap set-nth ] keep f
+ [ unroll-factor 1 - swap set-nth ] keep f
] dip [ node boa dup ] keep
dup [ (>>prev) ] [ 2drop ] if ; inline
] [ dup front>> >>back ] if* drop ; inline
: push-front/new ( elt list -- )
- unroll-factor 1- >>front-pos
+ unroll-factor 1 - >>front-pos
[ <front-node> ] change-front
normalize-back ; inline
: push-front/existing ( elt list front -- )
- [ [ 1- ] change-front-pos ] dip
+ [ [ 1 - ] change-front-pos ] dip
[ front-pos>> ] [ data>> ] bi* set-nth-unsafe ; inline
M: unrolled-list push-front*
: pop-front/existing ( list front -- )
[ dup front-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
- [ 1+ ] change-front-pos
+ [ 1 + ] change-front-pos
drop ; inline
M: unrolled-list pop-front*
dup front>> [ empty-unrolled-list ] unless*
- over front-pos>> unroll-factor 1- eq?
+ over front-pos>> unroll-factor 1 - eq?
[ pop-front/new ] [ pop-front/existing ] if ;
: <back-node> ( elt back -- node )
normalize-front ; inline
: push-back/existing ( elt list back -- )
- [ [ 1+ ] change-back-pos ] dip
- [ back-pos>> 1- ] [ data>> ] bi* set-nth-unsafe ; inline
+ [ [ 1 + ] change-back-pos ] dip
+ [ back-pos>> 1 - ] [ data>> ] bi* set-nth-unsafe ; inline
M: unrolled-list push-back*
dup [ back>> ] [ back-pos>> unroll-factor eq? not ] bi
M: unrolled-list peek-back
dup back>>
- [ [ back-pos>> 1- ] dip data>> nth-unsafe ]
+ [ [ back-pos>> 1 - ] dip data>> nth-unsafe ]
[ empty-unrolled-list ]
if* ;
dup back>> [ normalize-front ] [ f >>front drop ] if ; inline
: pop-back/existing ( list back -- )
- [ [ 1- ] change-back-pos ] dip
+ [ [ 1 - ] change-back-pos ] dip
[ dup back-pos>> ] [ data>> ] bi* [ 0 ] 2dip set-nth-unsafe
drop ; inline
2dup length 2 - >= [
2drop
] [
- [ 1+ dup 2 + ] dip subseq hex> [ , ] when*
+ [ 1 + dup 2 + ] dip subseq hex> [ , ] when*
] if ;
: url-decode-% ( index str -- index str )
2dup nth dup CHAR: % = [
drop url-decode-% [ 3 + ] dip
] [
- , [ 1+ ] dip
+ , [ 1 + ] dip
] if url-decode-iter
] if ;
[ f ] [ foo ] unit-test\r
[ ] [ 3 to: foo ] unit-test\r
[ 3 ] [ foo ] unit-test\r
-[ ] [ \ foo [ 1+ ] change-value ] unit-test\r
+[ ] [ \ foo [ 1 + ] change-value ] unit-test\r
[ 4 ] [ foo ] unit-test\r
M: vlist ppush
>vlist<
2dup length = [ unshare ] unless
- [ [ 1+ swap ] dip push ] keep vlist boa ;
+ [ [ 1 + swap ] dip push ] keep vlist boa ;
ERROR: empty-vlist-error ;
M: vlist ppop
[ empty-vlist-error ]
- [ [ length>> 1- ] [ vector>> ] bi vlist boa ] if-empty ;
+ [ [ length>> 1 - ] [ vector>> ] bi vlist boa ] if-empty ;
M: vlist clone
[ length>> ] [ vector>> >vector ] bi vlist boa ;
: valist-at ( key i array -- value ? )
over 0 >= [
3dup nth-unsafe = [
- [ 1+ ] dip nth-unsafe nip t
+ [ 1 + ] dip nth-unsafe nip t
] [
[ 2 - ] dip valist-at
] if
"windows.com.wrapper.callbacks" create-vocab drop
: (next-vtbl-counter) ( -- n )
- +vtbl-counter+ [ 1+ dup ] change ;
+ +vtbl-counter+ [ 1 + dup ] change ;
: com-unwrap ( wrapped -- object )
+wrapped-objects+ get-global at*
: (make-add-ref) ( interfaces -- quot )
length "void*" heap-size * '[
_
- [ alien-unsigned-4 1+ dup ]
+ [ alien-unsigned-4 1 + dup ]
[ set-alien-unsigned-4 ]
2bi
] ;
length "void*" heap-size * '[
_
[ drop ]
- [ alien-unsigned-4 1- dup ]
+ [ alien-unsigned-4 1 - dup ]
[ set-alien-unsigned-4 ]
2tri
dup 0 = [ swap (free-wrapped-object) ] [ nip ] if
"windows.com.wrapper.callbacks" create ;
: (finish-thunk) ( param-count thunk quot -- thunked-quot )
- [ [ drop [ ] ] [ swap 1- '[ _ _ ndip ] ] if-empty ]
+ [ [ drop [ ] ] [ swap 1 - '[ _ _ ndip ] ] if-empty ]
dip compose ;
: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
: filenames-from-hdrop ( hdrop -- filenames )\r
dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files\r
[\r
- 2dup f 0 DragQueryFile 1+ ! get size of filename buffer\r
+ 2dup f 0 DragQueryFile 1 + ! get size of filename buffer\r
dup "WCHAR" <c-array>\r
[ swap DragQueryFile drop ] keep\r
alien>u16-string\r
: line-offset>x ( n script-string -- x )
2dup string>> length = [
ssa>> ! ssa
- swap 1- ! icp
+ swap 1 - ! icp
TRUE ! fTrailing
] [
ssa>>
: number<-> ( doc -- dup )
0 over [
dup var>> [
- over >>var [ 1+ ] dip
+ over >>var [ 1 + ] dip
] unless drop
] each-interpolated drop ;
swap
[ version-1.0?>> over text? not ]
[ check>> ] bi and [
- spot get [ 1+ ] change-column drop
+ spot get [ 1 + ] change-column drop
disallowed-char
] [ drop ] if
] [ drop ] if* ;
: record ( spot char -- spot )
over char>> [
CHAR: \n =
- [ [ 1+ ] change-line -1 ] [ dup column>> 1+ ] if
+ [ [ 1 + ] change-line -1 ] [ dup column>> 1 + ] if
>>column
] [ drop ] if ;
: take-string ( match -- string )
dup length <circular-string>
spot get '[ 2dup _ string-matches? ] take-until nip
- dup length rot length 1- - head
+ dup length rot length 1 - - head
get-char [ missing-close ] unless next ;
: expect ( string -- )
: next-token, ( len id -- )
[ position get 2dup + ] dip token,
- position get + dup 1- position set last-offset set ;
+ position get + dup 1 - position set last-offset set ;
: push-context ( rules -- )
context [ <line-context> ] change ;
-IN: assocs.tests
USING: kernel math namespaces make tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
continuations specialized-arrays.double ;
+IN: assocs.tests
[ t ] [ H{ } dup assoc-subset? ] unit-test
[ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test
H{ { 1 3 } { 2 5 } }
H{ { 1 7 } { 5 6 } }
} assoc-refine
-] unit-test
\ No newline at end of file
+] unit-test
-IN: byte-arrays.tests\r
USING: tools.test byte-arrays sequences kernel ;\r
+IN: byte-arrays.tests\r
\r
[ 6 B{ 1 2 3 } ] [\r
6 B{ 1 2 3 } resize-byte-array\r
\r
[ -10 B{ } resize-byte-array ] must-fail\r
\r
-[ B{ 123 } ] [ 123 1byte-array ] unit-test
\ No newline at end of file
+[ B{ 123 } ] [ 123 1byte-array ] unit-test\r
-IN: byte-vectors.tests\r
USING: tools.test byte-vectors vectors sequences kernel\r
prettyprint ;\r
+IN: byte-vectors.tests\r
\r
[ 0 ] [ 123 <byte-vector> length ] unit-test\r
\r
+++ /dev/null
-IN: checksums.tests
-USING: checksums tools.test ;
-
-IN: classes.builtin.tests
USING: tools.test words sequences kernel memory accessors ;
+IN: classes.builtin.tests
[ f ] [
[ word? ] instances
-IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes
sequences math kernel slots tools.test parser compiler.units
arrays classes.tuple eval multiline ;
+IN: classes.tuple.parser.tests
TUPLE: test-1 ;
"USE: classes.tuple.parser.tests T{ parsing-corner-case {"
" x 3 }"
} "\n" join eval( -- tuple )
-] [ error>> unexpected-eof? ] must-fail-with
\ No newline at end of file
+] [ error>> unexpected-eof? ] must-fail-with
-IN: effects.tests
USING: effects tools.test prettyprint accessors sequences ;
+IN: effects.tests
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
[ f ] [ 1 0 <effect> 2 2 <effect> effect<= ] unit-test
[ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test
[ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test
-[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test
\ No newline at end of file
+[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test
-IN: generic.math.tests
USING: generic.math math tools.test kernel ;
+IN: generic.math.tests
! Test math-combination
[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test
-IN: generic.single.tests
USING: tools.test math math.functions math.constants generic.standard
generic.single strings sequences arrays kernel accessors words
specialized-arrays.double byte-arrays bit-arrays parser namespaces
make quotations stack-checker vectors growable hashtables sbufs
prettyprint byte-vectors bit-vectors specialized-vectors.double
definitions generic sets graphs assocs grouping see eval ;
+IN: generic.single.tests
GENERIC: lo-tag-test ( obj -- obj' )
! Corner case
[ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
[ error>> bad-dispatch-position? ]
-must-fail-with
\ No newline at end of file
+must-fail-with
-IN: hashtables.tests
USING: kernel math namespaces make tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
continuations ;
+IN: hashtables.tests
[ f ] [ "hi" V{ 1 2 3 } at ] unit-test
[ 1 ] [ 2 "h" get at ] unit-test
! Random test case
-[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
\ No newline at end of file
+[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
-IN: io.backend.tests
USING: tools.test io.backend kernel ;
+IN: io.backend.tests
[ ] [ "a" normalize-path drop ] unit-test
M: memory-stream stream-read1
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
- [ [ 1+ ] change-index drop ] bi ;
+ [ [ 1 + ] change-index drop ] bi ;
-IN: system.tests\r
USING: layouts math tools.test ;\r
+IN: system.tests\r
\r
[ t ] [ cell integer? ] unit-test\r
[ t ] [ bootstrap-cell integer? ] unit-test\r
-IN: slots.tests
USING: math accessors slots strings generic.single kernel
tools.test generic words parser eval math.functions ;
+IN: slots.tests
TUPLE: r/w-test foo ;
\r
: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
\r
-: dimension ( array -- x ) length 1- ; inline \r
+: dimension ( array -- x ) length 1 - ; inline \r
: change-last ( seq quot -- ) \r
[ [ dimension ] keep ] dip change-nth ; inline\r
\r
: point-inside-or-on-halfspace? ( halfspace v -- ? ) \r
position-point VERY-SMALL-NUM neg > ;\r
: project-vector ( seq -- seq ) \r
- pv> [ head ] [ 1+ tail ] 2bi append ; \r
+ pv> [ head ] [ 1 + tail ] 2bi append ; \r
: get-intersection ( matrice -- seq ) \r
[ 1 tail* ] map flip first ;\r
\r
: compute-adjacencies ( solid -- solid )\r
dup dimension>> [ >= ] curry \r
[ keep swap ] curry MAX-FACE-PER-CORNER swap\r
- [ [ test-faces-combinaisons ] 2keep 1- ] while drop ;\r
+ [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ;\r
\r
: find-adjacencies ( solid -- solid ) \r
erase-old-adjacencies \r
[ [ non-empty-solid? ] filter ] change-solids ;\r
\r
: projected-space ( space solids -- space ) \r
- swap dimension>> 1- <space> \r
+ swap dimension>> 1 - <space> \r
swap >>dimension swap >>solids ;\r
\r
: get-silhouette ( solid -- silhouette ) \r
! { [ dup 0 = ] [ 2drop { { } } ] }\r
! { [ over empty? ] [ 2drop { } ] }\r
! { [ t ] [ \r
-! [ [ 1- (combinations) ] [ drop first ] 2bi prefix-each ]\r
+! [ [ 1 - (combinations) ] [ drop first ] 2bi prefix-each ]\r
! [ (combinations) ] 2bi append\r
! ] }\r
! } cond ;\r
{ [ over 1 = ] [ 3drop columnize ] }\r
{ [ over 0 = ] [ 2drop 2drop { } ] }\r
{ [ 2dup < ] [ 2drop [ 1 cut ] dip \r
- [ 1- among [ append ] with map ] \r
+ [ 1 - among [ append ] with map ] \r
[ among append ] 2bi\r
] }\r
{ [ 2dup = ] [ 3drop 1array ] }\r
: do-row ( exchange-with row# -- )\r
[ exchange-rows ] keep\r
[ first-col ] keep\r
- dup 1+ rows-from clear-col ;\r
+ dup 1 + rows-from clear-col ;\r
\r
: find-row ( row# quot -- i elt )\r
[ rows-from ] dip find ; inline\r
\r
: (echelon) ( col# row# -- )\r
over cols < over rows < and [\r
- 2dup pivot-row [ over do-row 1+ ] when*\r
- [ 1+ ] dip (echelon)\r
+ 2dup pivot-row [ over do-row 1 + ] when*\r
+ [ 1 + ] dip (echelon)\r
] [\r
2drop\r
] if ;\r
: four ( -- x )
!BROKEN this code is broken
- 2 2 + 1+ ;
+ 2 2 + 1 + ;
: five ( -- x )
!TODO return 5
remaining 1 <= [
listener call f
] [
- remaining 1-
+ remaining 1 -
0
value' 10 *
used mask bitor
] any? ; inline recursive
:: count-numbers ( max listener -- )
- 10 iota [ 1+ 1 1 0 max listener (count-numbers) ] any? drop ;
+ 10 iota [ 1 + 1 1 0 max listener (count-numbers) ] any? drop ;
inline
:: beust ( -- )
[let | i! [ 0 ] |
- 5000000000 [ i 1+ i! ] count-numbers
+ 5000000000 [ i 1 + i! ] count-numbers
i number>string " unique numbers." append print
] ;
: count ( quot: ( -- ? ) -- n )
#! Call quot until it returns false, return number of times
#! it was true
- [ 0 ] dip '[ _ dip swap [ [ 1+ ] when ] keep ] loop ; inline
+ [ 0 ] dip '[ _ dip swap [ [ 1 + ] when ] keep ] loop ; inline
: count-flips ( perm -- flip# )
'[
[ CHAR: 0 + write1 ] each nl ; inline
: fannkuch-step ( counter max-flips perm -- counter max-flips )
- pick 30 < [ [ 1+ ] [ ] [ dup write-permutation ] tri* ] when
+ pick 30 < [ [ 1 + ] [ ] [ dup write-permutation ] tri* ] when
count-flips max ; inline
: fannkuch ( n -- )
[
- [ 0 0 ] dip [ 1+ ] B{ } map-as
+ [ 0 0 ] dip [ 1 + ] B{ } map-as
[ fannkuch-step ] each-permutation nip
] keep
"Pfannkuchen(" write pprint ") = " write . ;
dup i>> 1 <= [
drop 1 <box>
] [
- i>> 1- <box>
+ i>> 1 - <box>
dup tuple-fib
swap
- i>> 1- <box>
+ i>> 1 - <box>
tuple-fib
swap i>> swap i>> + <box>
] if ; inline recursive
-IN: benchmark.fib6\r
USING: math kernel alien ;\r
+IN: benchmark.fib6\r
\r
: fib ( x -- y )\r
"int" { "int" } "cdecl" [\r
dup 1 <= [ drop 1 ] [\r
- 1- dup fib swap 1- fib +\r
+ 1 - dup fib swap 1- fib +\r
] if\r
] alien-callback\r
"int" { "int" } "cdecl" alien-indirect ;\r
USING: math sequences kernel ;
IN: benchmark.gc1
-: gc1 ( -- ) 6000000 [ >bignum 1+ ] map drop ;
+: gc1 ( -- ) 6000000 [ >bignum 1 + ] map drop ;
-MAIN: gc1
\ No newline at end of file
+MAIN: gc1
: tally ( x exemplar -- b )
clone tuck
[
- [ [ 1+ ] [ 1 ] if* ] change-at
+ [ [ 1 + ] [ 1 ] if* ] change-at
] curry each ;
: small-groups ( x n -- b )
swap
- [ length swap - 1+ ] 2keep
+ [ length swap - 1 + ] 2keep
[ [ over + ] dip subseq ] 2curry map ;
: handle-table ( inputs n -- )
: <color-map> ( nb-cols -- map )
dup [
- 360 * swap 1+ / sat val
+ 360 * swap 1 + / sat val
1 <hsva> >rgba scale-rgb
] with map ;
:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
bodies [| body i |
body each-quot call
- bodies i 1+ tail-slice [
+ bodies i 1 + tail-slice [
body pair-quot call
] each
] each-index ; inline
-IN: benchmark.nsieve-bits
USING: math math.parser sequences sequences.private kernel
bit-arrays make io ;
+IN: benchmark.nsieve-bits
: clear-flags ( step i seq -- )
2dup length >= [
2dup length < [
2dup nth-unsafe [
over dup 2 * pick clear-flags
- rot 1+ -rot ! increment count
- ] when [ 1+ ] dip (nsieve-bits)
+ rot 1 + -rot ! increment count
+ ] when [ 1 + ] dip (nsieve-bits)
] [
2drop
] if ; inline recursive
: nsieve-bits ( m -- count )
- 0 2 rot 1+ <bit-array> dup set-bits (nsieve-bits) ;
+ 0 2 rot 1 + <bit-array> dup set-bits (nsieve-bits) ;
: nsieve-bits. ( m -- )
[ "Primes up to " % dup # " " % nsieve-bits # ] "" make
: nsieve-bits-main ( n -- )
dup 2^ 10000 * nsieve-bits.
- dup 1- 2^ 10000 * nsieve-bits.
+ dup 1 - 2^ 10000 * nsieve-bits.
2 - 2^ 10000 * nsieve-bits. ;
: nsieve-bits-main* ( -- ) 11 nsieve-bits-main ;
2dup length < [
2dup nth-unsafe 0 > [
over dup 2 * pick clear-flags
- rot 1+ -rot ! increment count
- ] when [ 1+ ] dip (nsieve)
+ rot 1 + -rot ! increment count
+ ] when [ 1 + ] dip (nsieve)
] [
2drop
] if ; inline recursive
: nsieve ( m -- count )
- 0 2 rot 1+ <byte-array> dup [ drop 1 ] change-each (nsieve) ;
+ 0 2 rot 1 + <byte-array> dup [ drop 1 ] change-each (nsieve) ;
: nsieve. ( m -- )
[ "Primes up to " % dup # " " % nsieve # ] "" make print ;
-IN: benchmark.nsieve
USING: math math.parser sequences sequences.private kernel
arrays make io ;
+IN: benchmark.nsieve
: clear-flags ( step i seq -- )
2dup length >= [
2dup length < [
2dup nth-unsafe [
over dup 2 * pick clear-flags
- rot 1+ -rot ! increment count
- ] when [ 1+ ] dip (nsieve)
+ rot 1 + -rot ! increment count
+ ] when [ 1 + ] dip (nsieve)
] [
2drop
] if ; inline recursive
: nsieve ( m -- count )
- 0 2 rot 1+ t <array> (nsieve) ;
+ 0 2 rot 1
+ t <array> (nsieve) ;
: nsieve. ( m -- )
[ "Primes up to " % dup # " " % nsieve # ] "" make print ;
IN: benchmark.partial-sums
! Helper words
-: summing-integers ( n quot -- y ) [ 0.0 ] 2dip '[ 1+ @ + ] each ; inline
+: summing-integers ( n quot -- y ) [ 0.0 ] 2dip '[ 1 + @ + ] each ; inline
: summing-floats ( n quot -- y ) '[ >float @ ] summing-integers ; inline
: cube ( x -- y ) dup dup * * ; inline
-: -1^ ( n -- -1/1 ) 2 mod 2 * 1- ; inline
+: -1^ ( n -- -1/1 ) 2 mod 2 * 1 - ; inline
! The functions
-: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing-floats ; inline
+: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1 - ^ ] summing-floats ; inline
: k^-0.5 ( n -- y ) [ -0.5 ^ ] summing-floats ; inline
-: 1/k(k+1) ( n -- y ) [ dup 1+ * recip ] summing-floats ; inline
+: 1/k(k+1) ( n -- y ) [ dup 1 + * recip ] summing-floats ; inline
: flint-hills ( n -- y ) [ [ cube ] [ sin sq ] bi * recip ] summing-floats ; inline
: cookson-hills ( n -- y ) [ [ cube ] [ cos sq ] bi * recip ] summing-floats ; inline
: harmonic ( n -- y ) [ recip ] summing-floats ; inline
: riemann-zeta ( n -- y ) [ sq recip ] summing-floats ; inline
: alternating-harmonic ( n -- y ) [ [ -1^ ] keep /f ] summing-integers ; inline
-: gregory ( n -- y ) [ [ -1^ ] [ 2.0 * 1- ] bi / ] summing-integers ; inline
+: gregory ( n -- y ) [ [ -1^ ] [ 2.0 * 1 - ] bi / ] summing-integers ; inline
: partial-sums ( n -- results )
[
: ack ( m n -- x )
{
- { [ over zero? ] [ nip 1+ ] }
- { [ dup zero? ] [ drop 1- 1 ack ] }
- [ [ drop 1- ] [ 1- ack ] 2bi ack ]
+ { [ over zero? ] [ nip 1 + ] }
+ { [ dup zero? ] [ drop 1 - 1 ack ] }
+ [ [ drop 1 - ] [ 1 - ack ] 2bi ack ]
} cond ; inline recursive
: tak ( x y z -- t )
2over <= [
2nip
] [
- [ rot 1- -rot tak ]
- [ -rot 1- -rot tak ]
- [ 1- -rot tak ]
+ [ rot 1 - -rot tak ]
+ [ -rot 1 - -rot tak ]
+ [ 1 - -rot tak ]
3tri
tak
] if ; inline recursive
: recursive ( n -- )
[ 3 swap ack . flush ]
[ 27.0 + fib . flush ]
- [ 1- [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri
+ [ 1 - [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri
3 fib . flush
3.0 2.0 1.0 tak . flush ;
: tuple-array-benchmark ( -- )
100 [
drop 5000 <point-array> [
- [ 1+ ] change-x
- [ 1- ] change-y
- [ 1+ 2 / ] change-z
+ [ 1 + ] change-x
+ [ 1 - ] change-y
+ [ 1 + 2 / ] change-z
] map [ z>> ] sigma
] sigma . ;
-MAIN: tuple-array-benchmark
\ No newline at end of file
+MAIN: tuple-array-benchmark
: next-draw ( gadget -- )
dup [ draw-seq>> ] [ draw-n>> ] bi
- 1+ swap length mod
+ 1 + swap length mod
>>draw-n relayout-1 ;
: make-draws ( gadget -- draw-seq )
TUPLE: test-disp-cent value disposed ;
! A phony destructor that adds 1 to the value so we can make sure it got called.
-M: test-disp-cent dispose* dup value>> 1+ >>value drop ;
+M: test-disp-cent dispose* dup value>> 1 + >>value drop ;
DISPOSABLE-CENTRAL: t-d-c
: test-t-d-c ( -- n )
test-disp-cent new 3 >>value [ t-d-c ] with-t-d-c value>> ;
-[ 4 ] [ test-t-d-c ] unit-test
\ No newline at end of file
+[ 4 ] [ test-t-d-c ] unit-test
[ drop 1 coyield* 2 coyield* 3 coterminate ] cocreate ;
: test2 ( -- co )
- [ 1+ coyield* ] cocreate ;
+ [ 1 + coyield* ] cocreate ;
test1 dup *coresume . dup *coresume . dup *coresume . dup *coresume 2drop
[ test2 42 over coresume . dup *coresume . drop ] must-fail
{ "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
\ No newline at end of file
+{ 4+2/3 } [ [ 1 + coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test
: barrett-mu ( n size -- mu )
#! Calculates Barrett's reduction parameter mu
#! size = word size in bits (8, 16, 32, 64, ...)
- [ [ log2 1+ ] [ / 2 * ] bi* ]
+ [ [ log2 1 + ] [ / 2 * ] bi* ]
[ 2^ rot ^ swap /i ] 2bi ;
"./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" nth ; inline
: to64 ( v n -- string )
- [ [ -6 shift ] [ 6 2^ 1- bitand lookup-table ] bi ]
+ [ [ -6 shift ] [ 6 2^ 1 - bitand lookup-table ] bi ]
replicate nip ; inline
PRIVATE>
: modulus-phi ( numbits -- n phi )
#! Loop until phi is not divisible by the public key.
dup rsa-primes [ * ] 2keep
- [ 1- ] bi@ *
+ [ 1 - ] bi@ *
dup public-key gcd nip 1 = [
rot drop
] [
H{ } clone swap [ swap [ etag-add ] keep ] each ;
: lines>bytes ( seq n -- bytes )
- head 0 [ length 1+ + ] reduce ;
+ head 0 [ length 1 + + ] reduce ;
: file>lines ( path -- lines )
ascii file-lines ;
1 HEX: 7f <string> %
second dup number>string %
1 CHAR: , <string> %
- 1- lines>bytes number>string %
+ 1 - lines>bytes number>string %
] "" make ;
: etag-length ( vector -- n )
[ etag-strings ] dip ascii set-file-lines ;
: etags ( path -- )
- [ (ctags) sort-values etag-hash >alist ] dip etags-write ;
\ No newline at end of file
+ [ (ctags) sort-values etag-hash >alist ] dip etags-write ;
>from-sequence< nth-unsafe ;
M: from-sequence cursor-advance
- [ 1+ ] change-n drop ;
+ [ 1 + ] change-n drop ;
: >input ( seq -- cursor )
0 from-sequence boa ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! have-delegates?
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
: is-soa? ( name -- ? ) SOA IN query boa matching-rrs empty? not ;
KEY EC_KEY_get0_public_key dup
[| PUB |
KEY EC_KEY_get0_group :> GROUP
- GROUP EC_GROUP_get_degree bits>bytes 1+ :> LEN
+ GROUP EC_GROUP_get_degree bits>bytes 1 + :> LEN
LEN <byte-array> :> BIN
GROUP PUB POINT_CONVERSION_COMPRESSED BIN LEN f
EC_POINT_point2oct ssl-error
LEN *uint SIG resize ;
: ecdsa-verify ( dgst sig -- ? )
- ec-key-handle [ 0 -rot [ dup length ] bi@ ] dip ECDSA_verify 0 > ;
\ No newline at end of file
+ ec-key-handle [ 0 -rot [ dup length ] bi@ ] dip ECDSA_verify 0 > ;
<PRIVATE
: redraw ( loop -- )
- [ 1+ ] change-frame-number
+ [ 1 + ] change-frame-number
[ tick-slice ] [ delegate>> ] bi draw* ;
: tick ( loop -- )
delegate>> tick* ;
: increment-tick ( loop -- )
- [ 1+ ] change-tick-number
+ [ 1 + ] change-tick-number
dup tick-length>> [ + ] curry change-last-tick
drop ;
: ?tick ( loop count -- )
[ millis >>last-tick drop ] [
over [ since-last-tick ] [ tick-length>> ] bi >=
- [ [ drop increment-tick ] [ drop tick ] [ 1- ?tick ] 2tri ]
+ [ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ]
[ 2drop ] if
] if-zero ;
: (mint) ( tuple counter -- tuple )
2dup set-suffix checksummed-bits pick
- valid-guess? [ drop ] [ 1+ (mint) ] if ;
+ valid-guess? [ drop ] [ 1 + (mint) ] if ;
PRIVATE>
: find-nth ( seq quot n -- i elt )
[ <enum> >alist ] 2dip -rot
- '[ _ [ second @ ] find-from rot drop swap 1+ ]
+ '[ _ [ second @ ] find-from rot drop swap 1 + ]
[ f 0 ] 2dip times drop first2 ; inline
: find-first-name ( vector string -- i/f tag/f )
: find-between* ( vector i/f tag/f -- vector )
over integer? [
[ tail-slice ] [ name>> ] bi*
- dupd find-matching-close drop dup [ 1+ ] when
+ dupd find-matching-close drop dup [ 1 + ] when
[ head ] [ first ] if*
] [
3drop V{ } clone
0 [ [ 7 shift ] dip bitor ] reduce ;
: synchsafe>seq ( n -- seq )
- dup 1+ log2 1+ 7 / ceiling
+ dup 1 + log2 1 + 7 / ceiling
[ [ -7 shift ] keep HEX: 7f bitand ] replicate nip reverse ;
: filter-text-data ( data -- filtered )
: do-connect ( server port quot: ( host port -- stream ) attempts -- stream/f )
dup 0 > [
[ drop call( host port -- stream ) ]
- [ drop 15 sleep 1- do-connect ]
+ [ drop 15 sleep 1 - do-connect ]
recover
] [ 2drop 2drop f ] if ;
C: <segment> segment
: segment-number++ ( segment -- )
- [ number>> 1+ ] keep (>>number) ;
+ [ number>> 1 + ] keep (>>number) ;
: clamp-length ( n seq -- n' )
0 swap length clamp ;
: (random-segments) ( segments n -- segments )
dup 0 > [
- [ dup last random-segment over push ] dip 1- (random-segments)
+ [ dup last random-segment over push ] dip 1 - (random-segments)
] [ drop ] if ;
CONSTANT: default-segment-radius 1
rot dup length swap <slice> find-nearest-segment ;
: nearest-segment-backward ( segments oint start -- segment )
- swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
+ swapd 1 + 0 spin <slice> <reversed> find-nearest-segment ;
: nearest-segment ( segments oint start-segment -- segment )
#! find the segment nearest to 'oint', and return it.
over clamp-length swap nth ;
: next-segment ( segments current-segment -- segment )
- number>> 1+ get-segment ;
+ number>> 1 + get-segment ;
: previous-segment ( segments current-segment -- segment )
- number>> 1- get-segment ;
+ number>> 1 - get-segment ;
: heading-segment ( segments current-segment heading -- segment )
#! the next segment on the given heading
: inversions ( seq -- n )
0 swap [ length ] keep [
- [ nth ] 2keep swap 1+ tail-slice (inversions) +
+ [ nth ] 2keep swap 1 + tail-slice (inversions) +
] curry each ;
: duplicates? ( seq -- ? )
! Computing a basis
: graded ( seq -- seq )
- dup 0 [ length max ] reduce 1+ [ V{ } clone ] replicate
+ dup 0 [ length max ] reduce 1 + [ V{ } clone ] replicate
[ dup length pick nth push ] reduce ;
: nth-basis-elt ( generators n -- elt )
! Graded by degree
: (graded-ker/im-d) ( n seq -- null/rank )
#! d: C(n) ---> C(n+1)
- [ ?nth ] [ [ 1+ ] dip ?nth ] 2bi
+ [ ?nth ] [ [ 1 + ] dip ?nth ] 2bi
dim-im/ker-d ;
: graded-ker/im-d ( graded-basis -- seq )
] if ;
: graded-triple ( seq n -- triple )
- 3 [ 1- + ] with map swap [ ?nth ] curry map ;
+ 3 [ 1 - + ] with map swap [ ?nth ] curry map ;
: graded-triples ( seq -- triples )
dup length [ graded-triple ] with map ;
: stirling-fact ( n -- fact )
[ pi 2 * * sqrt ]
[ [ e / ] keep ^ ]
- [ 12 * recip 1+ ] tri * * ;
+ [ 12 * recip 1 + ] tri * * ;
MACRO: chain-rule ( word -- e )
[ input-length '[ _ duals>nweave ] ]
[ "derivative" word-prop ]
- [ input-length 1+ '[ _ nspread ] ]
+ [ input-length 1 + '[ _ nspread ] ]
tri
'[ [ @ _ @ ] sum-outputs ] ;
! Specialize math functions to operate on dual numbers.
[ all-words [ "derivative" word-prop ] filter
- [ define-dual ] each ] with-compilation-unit
\ No newline at end of file
+ [ define-dual ] each ] with-compilation-unit
<PRIVATE
: weighted ( x y a -- z )
- tuck [ * ] [ 1- neg * ] 2bi* + ;
+ tuck [ * ] [ 1 - neg * ] 2bi* + ;
: a ( n -- a )
- 1+ 2 swap / ;
+ 1 + 2 swap / ;
PRIVATE>
: lprimes ( -- list ) 2 [ next-prime ] lfrom-by ;
: lprimes-from ( n -- list )
- dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ;
+ dup 3 < [ drop lprimes ] [ 1 - next-prime [ next-prime ] lfrom-by ] if ;
} cond ;
: over-1000000 ( n -- str )
- 3 digit-groups [ 1+ units nth n-units ] map-index sift
+ 3 digit-groups [ 1 + units nth n-units ] map-index sift
reverse " " join ;
: decompose ( n -- str ) 1000000 /mod [ over-1000000 ] dip complete ;
] unit-test
LAZY: nats-from ( n -- list )
- dup 1+ nats-from cons ;
+ dup 1 + nats-from cons ;
: nats ( -- list ) 0 nats-from ;
ui.gadgets.worlds ui.render accessors combinators literals ;
IN: opengl.demo-support
-CONSTANT: FOV $[ 2.0 sqrt 1+ ]
+CONSTANT: FOV $[ 2.0 sqrt 1 + ]
CONSTANT: MOUSE-MOTION-SCALE 0.5
CONSTANT: KEY-ROTATE-STEP 10.0
2drop epsilon
] [
2dup exactly-n
- -rot 1- at-most-n <|>
+ -rot 1 - at-most-n <|>
] if ;
: at-least-n ( parser n -- parser' )
:: prepare-pos ( v i -- c l )
[let | n [ i v head-slice ] |
- v CHAR: \n n last-index -1 or 1+ -
- n [ CHAR: \n = ] count 1+
+ v CHAR: \n n last-index -1 or 1 + -
+ n [ CHAR: \n = ] count 1 +
] ;
: store-pos ( v a -- )
[ swap hash>> set-at ]
} case ;
-:: at-pos ( t l c -- p ) t l head-slice [ length ] map sum l 1- + c + ;
+:: at-pos ( t l c -- p ) t l head-slice [ length ] map sum l 1 - + c + ;
M: lex-hash at*
swap {
{ input [ drop lexer get text>> "\n" join t ] }
- { pos [ drop lexer get [ text>> ] [ line>> 1- ] [ column>> 1+ ] tri at-pos t ] }
+ { pos [ drop lexer get [ text>> ] [ line>> 1 - ] [ column>> 1 + ] tri at-pos t ] }
[ swap hash>> at* ]
} case ;
spaces = space* => [[ drop ignore ]]
chunk = (!(space) .)+ => [[ >string ]]
expr = spaces chunk
-;EBNF
\ No newline at end of file
+;EBNF
<PRIVATE
: sum-divisible-by ( target n -- m )
- [ /i dup 1+ * ] keep * 2 /i ;
+ [ /i dup 1 + * ] keep * 2 /i ;
PRIVATE>
! --------
: euler012 ( -- answer )
- 8 [ dup nth-triangle tau* 500 < ] [ 1+ ] while nth-triangle ;
+ 8 [ dup nth-triangle tau* 500 < ] [ 1 + ] while nth-triangle ;
! [ euler012 ] 10 ave-time
! 6573 ms ave run time - 346.27 SD (10 trials)
<PRIVATE
: next-collatz ( n -- n )
- dup even? [ 2 / ] [ 3 * 1+ ] if ;
+ dup even? [ 2 / ] [ 3 * 1 + ] if ;
: longest ( seq seq -- seq )
2dup [ length ] bi@ > [ drop ] [ nip ] if ;
<PRIVATE
: worth-calculating? ( n -- ? )
- 1- 3 { [ divisor? ] [ / even? ] } 2&& ;
+ 1 - 3 { [ divisor? ] [ / even? ] } 2&& ;
PRIVATE>
ascii file-contents [ quotable? ] filter "," split ;
: name-scores ( seq -- seq )
- [ 1+ swap alpha-value * ] map-index ;
+ [ 1 + swap alpha-value * ] map-index ;
PRIVATE>
<PRIVATE
: (digit-fib) ( n term -- term )
- 2dup fib number>string length > [ 1+ (digit-fib) ] [ nip ] if ;
+ 2dup fib number>string length > [ 1 + (digit-fib) ] [ nip ] if ;
: digit-fib ( n -- term )
1 (digit-fib) ;
<PRIVATE
: digit-fib* ( n -- term )
- 1- 5 log10 2 / + phi log10 / ceiling >integer ;
+ 1 - 5 log10 2 / + phi log10 / ceiling >integer ;
PRIVATE>
1 1000 (a,b) [ prime? ] filter [ 1 swap / ] map ;
: (mult-order) ( n a m -- k )
- 3dup ^ swap mod 1 = [ 2nip ] [ 1+ (mult-order) ] if ;
+ 3dup ^ swap mod 1 = [ 2nip ] [ 1 + (mult-order) ] if ;
PRIVATE>
dup sq -rot * + + ;
: (consecutive-primes) ( b a n -- m )
- 3dup quadratic prime? [ 1+ (consecutive-primes) ] [ 2nip ] if ;
+ 3dup quadratic prime? [ 1 + (consecutive-primes) ] [ 2nip ] if ;
: consecutive-primes ( a b -- m )
swap 0 (consecutive-primes) ;
PRIVATE>
: euler030 ( -- answer )
- 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1- ;
+ 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1 - ;
! [ euler030 ] 100 ave-time
! 1700 ms ave run time - 64.84 SD (100 trials)
: (circular?) ( seq n -- ? )
dup 0 > [
2dup rotate 10 digits>integer
- prime? [ 1- (circular?) ] [ 2drop f ] if
+ prime? [ 1 - (circular?) ] [ 2drop f ] if
] [
2drop t
] if ;
: circular? ( seq -- ? )
- dup length 1- (circular?) ;
+ dup length 1 - (circular?) ;
PRIVATE>
pick length 8 > [
2drop 10 digits>integer
] [
- [ * number>digits over push-all ] 2keep 1+ (concat-product)
+ [ * number>digits over push-all ] 2keep 1 + (concat-product)
] if ;
: concat-product ( n -- m )
p-count get length ;
: adjust-p-count ( n -- )
- max-p 1- over <range> p-count get
- [ [ 1+ ] change-nth ] curry each ;
+ max-p 1 - over <range> p-count get
+ [ [ 1 + ] change-nth ] curry each ;
: (count-perimeters) ( seq -- )
dup sum max-p < [
: (concat-upto) ( n limit str -- str )
2dup length > [
- pick number>string over push-all rot 1+ -rot (concat-upto)
+ pick number>string over push-all rot 1 + -rot (concat-upto)
] [
2nip
] if ;
SBUF" " clone 1 -rot (concat-upto) ;
: nth-integer ( n str -- m )
- [ 1- ] dip nth 1string string>number ;
+ [ 1 - ] dip nth 1string string>number ;
PRIVATE>
: (triangle-upto) ( limit n -- )
2dup nth-triangle > [
- dup nth-triangle , 1+ (triangle-upto)
+ dup nth-triangle , 1 + (triangle-upto)
] [
2drop
] if ;
<PRIVATE
: triangle? ( n -- ? )
- 8 * 1+ sqrt 1- 2 / 1 mod zero? ;
+ 8 * 1 + sqrt 1 - 2 / 1 mod zero? ;
PRIVATE>
<PRIVATE
: subseq-divisible? ( n index seq -- ? )
- [ 1- dup 3 + ] dip subseq 10 digits>integer swap divisor? ;
+ [ 1 - dup 3 + ] dip subseq 10 digits>integer swap divisor? ;
: interesting? ( seq -- ? )
{
<PRIVATE
: nth-pentagonal ( n -- seq )
- dup 3 * 1- * 2 / ;
+ dup 3 * 1 - * 2 / ;
: sum-and-diff? ( m n -- ? )
[ + ] [ - ] 2bi [ pentagonal? ] bi@ and ;
<PRIVATE
: nth-hexagonal ( n -- m )
- dup 2 * 1- * ;
+ dup 2 * 1 - * ;
DEFER: next-solution
dup pentagonal? [ nip ] [ drop next-solution ] if ;
: next-solution ( n -- m )
- 1+ dup nth-hexagonal (next-solution) ;
+ 1 + dup nth-hexagonal (next-solution) ;
PRIVATE>
dup perfect-squares [ 2 * - ] with map [ prime? ] any? ;
: next-odd-composite ( n -- m )
- dup odd? [ 2 + ] [ 1+ ] if dup prime? [ next-odd-composite ] when ;
+ dup odd? [ 2 + ] [ 1 + ] if dup prime? [ next-odd-composite ] when ;
: disprove-conjecture ( n -- m )
dup fits-conjecture? [ next-odd-composite disprove-conjecture ] when ;
swap - nip
] [
dup prime? [ [ drop 0 ] 2dip ] [
- 2dup unique-factors length = [ [ 1+ ] 2dip ] [ [ drop 0 ] 2dip ] if
- ] if 1+ (consecutive)
+ 2dup unique-factors length = [ [ 1 + ] 2dip ] [ [ drop 0 ] 2dip ] if
+ ] if 1 + (consecutive)
] if ;
: consecutive ( goal test -- n )
sieve get nth 0 = ;
: multiples ( n -- seq )
- sieve get length 1- over <range> ;
+ sieve get length 1 - over <range> ;
: increment-counts ( n -- )
- multiples [ sieve get [ 1+ ] change-nth ] each ;
+ multiples [ sieve get [ 1 + ] change-nth ] each ;
: prime-tau-upto ( limit -- seq )
dup initialize-sieve 2 swap [a,b) [
: count-digits ( n -- byte-array )
10 <byte-array> [
- '[ 10 /mod _ [ 1+ ] change-nth dup 0 > ] loop drop
+ '[ 10 /mod _ [ 1 + ] change-nth dup 0 > ] loop drop
] keep ;
HINTS: count-digits fixnum ;
2dup [ first ] bi@ > [ drop ] [ nip ] if ;
: continue? ( pair seq -- ? )
- [ first ] [ length 1- ] bi* < ;
+ [ first ] [ length 1 - ] bi* < ;
: (find-longest) ( best seq limit -- best )
[ longest-prime longest ] 2keep 2over continue? [
<PRIVATE
: map-nx ( n x -- seq )
- [ 1+ * ] with map ; inline
+ [ 1 + * ] with map ; inline
: all-same-digits? ( seq -- ? )
[ number>digits natural-sort ] map all-equal? ;
: next-all-same ( x n -- n )
dup candidate? [
2dup swap map-nx all-same-digits?
- [ nip ] [ 1+ next-all-same ] if
+ [ nip ] [ 1 + next-all-same ] if
] [
- 1+ next-all-same
+ 1 + next-all-same
] if ;
PRIVATE>
! (n-2)² + 4(n-1) = odd squares, no need to calculate
: prime-corners ( n -- m )
- 3 [1,b] swap '[ _ [ 1- * ] keep 2 - sq + prime? ] count ;
+ 3 [1,b] swap '[ _ [ 1 - * ] keep 2 - sq + prime? ] count ;
: total-corners ( n -- m )
- 1- 2 * ; foldable
+ 1 - 2 * ; foldable
: ratio-below? ( count length -- ? )
- total-corners 1+ / PERCENT_PRIME < ;
+ total-corners 1 + / PERCENT_PRIME < ;
: next-layer ( count length -- count' length' )
2 + [ prime-corners + ] keep ;
} cond product ;
: primorial-upto ( limit -- m )
- 1 swap '[ dup primorial _ <= ] [ 1+ dup primorial ] produce
+ 1 swap '[ dup primorial _ <= ] [ 1 + dup primorial ] produce
nip penultimate ;
PRIVATE>
p-count get length ;
: adjust-p-count ( n -- )
- max-p 1- over <range> p-count get
- [ [ 1+ ] change-nth ] curry each ;
+ max-p 1 - over <range> p-count get
+ [ [ 1 + ] change-nth ] curry each ;
: (count-perimeters) ( seq -- )
dup sum max-p < [
over zero? [
3drop
] [
- [ [ 1- 2array ] dip at ]
+ [ [ 1 - 2array ] dip at ]
[ [ use 2array ] dip at + ]
[ [ 2array ] dip set-at ] 3tri
] if ;
: (euler076) ( n -- m )
dup init
[ [ ways ] curry each-subproblem ]
- [ [ dup 2array ] dip at 1- ] 2bi ;
+ [ [ dup 2array ] dip at 1 - ] 2bi ;
PRIVATE>
567 [1,b] [ chain-ending ] map ;
: fast-chain-ending ( seq n -- m )
- dup 567 > [ next-link ] when 1- swap nth ;
+ dup 567 > [ next-link ] when 1 - swap nth ;
PRIVATE>
! --------
: euler097 ( -- answer )
- 2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1+ ;
+ 2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1 + ;
! [ euler097 ] 100 ave-time
! 0 ms ave run timen - 0.22 SD (100 trials)
flip first2 swap [ log ] map v* ;
: solve ( seq -- index )
- simplify [ supremum ] keep index 1+ ;
+ simplify [ supremum ] keep index 1 + ;
PRIVATE>
: euler100 ( -- answer )
1 1
- [ dup dup 1- * 2 * 10 24 ^ <= ]
+ [ dup dup 1 - * 2 * 10 24 ^ <= ]
[ tuck 6 * swap - 2 - ] while nip ;
! TODO: solution needs generalization
<PRIVATE
: nth* ( n seq -- elt/0 )
- [ length swap - 1- ] keep ?nth 0 or ;
+ [ length swap - 1 - ] keep ?nth 0 or ;
: next ( colortile seq -- )
[ nth* ] [ last + ] [ push ] tri ;
: ways ( length colortile -- permutations )
- V{ 1 } clone [ [ next ] 2curry times ] keep last 1- ;
+ V{ 1 } clone [ [ next ] 2curry times ] keep last 1 - ;
: (euler116) ( length -- permutations )
3 [1,b] [ ways ] with sigma ;
<PRIVATE
: sum-1toN ( n -- sum )
- dup 1+ * 2/ ; inline
+ dup 1 + * 2/ ; inline
: >base7 ( x -- y )
[ dup 0 > ] [ 7 /mod ] produce nip ;
: (use-digit) ( prev x index -- next )
- [ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ;
+ [ [ 1 + * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ;
: (euler148) ( x -- y )
>base7 0 [ (use-digit) ] reduce-index ;
:: (euler150) ( m -- n )
[let | table [ sums-triangle ] |
m [| x |
- x 1+ [| y |
+ x 1 + [| y |
m x - [0,b) [| z |
x z + table nth-unsafe
- [ y z + 1+ swap nth-unsafe ]
+ [ y z + 1 + swap nth-unsafe ]
[ y swap nth-unsafe ] bi -
] map partial-sum-infimum
] map-infimum
<=>
{
{ +lt+ [ ] }
- { +eq+ [ 1- ] }
- { +gt+ [ 1+ ] }
+ { +eq+ [ 1 - ] }
+ { +gt+ [ 1 + ] }
} case
] curry map-index ;
: (euler151) ( x -- y )
table get [ {
{ { 0 0 0 1 } [ 0 ] }
- { { 0 0 1 0 } [ { 0 0 0 1 } (euler151) 1+ ] }
- { { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1+ ] }
- { { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1+ ] }
+ { { 0 0 1 0 } [ { 0 0 0 1 } (euler151) 1 + ] }
+ { { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1 + ] }
+ { { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1 + ] }
[ [ dup length [ pick-sheet ] with map sum ] [ sum ] bi / ]
} case ] cache ;
{
{ [ dup 2 < ] [ drop 1 ] }
{ [ dup odd? ] [ 2/ fn ] }
- [ 2/ [ fn ] [ 1- fn ] bi + ]
+ [ 2/ [ fn ] [ 1 - fn ] bi + ]
} cond ;
: euler169 ( -- result )
: compute ( vec ratio -- )
{
- { [ dup integer? ] [ 1- 0 add-bits ] }
+ { [ dup integer? ] [ 1 - 0 add-bits ] }
{ [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] }
[ [ 1 mod compute ] 2keep >integer 0 add-bits ]
} cond ;
pick [ next ] [ next ] bi
[ = ] [
pick equate
- [ 1+ ] dip
+ [ 1 + ] dip
] 2unless? (p186)
] [
drop nip
PRIVATE>
:: P_m ( m -- P_m )
- m [1,b] [| i | 2 i * m 1+ / i ^ ] PI ;
+ m [1,b] [| i | 2 i * m 1 + / i ^ ] PI ;
: euler190 ( -- answer )
2 15 [a,b] [ P_m truncate ] sigma ;
[ 0 prefix ] [ 0 suffix ] bi [ + ] 2map ;
: generate ( n -- seq )
- 1- { 1 } [ (generate) ] iterate concat prune ;
+ 1 - { 1 } [ (generate) ] iterate concat prune ;
: squarefree ( n -- ? )
factors all-unique? ;
: first-row ( n -- t )
[ <failure> <success> <failure> ] dip
- 1- [| a b c | b c <block> a b ] times 2drop ;
+ 1 - [| a b c | b c <block> a b ] times 2drop ;
GENERIC: total ( t -- n )
M: block total [ total ] dup choice + ;
M: end total ways>> ;
: solve ( width height -- ways )
- [ first-row ] dip 1- [ next-row ] times total ;
+ [ first-row ] dip 1 - [ next-row ] times total ;
PRIVATE>
'[ _ gc benchmark 1000 / , ] tuck
'[ _ _ with-datastack drop ]
]
- [ 1- ] tri* swap times call
+ [ 1 - ] tri* swap times call
] { } make ; inline
: ave-time ( quot n -- )
<PRIVATE
: max-children ( seq -- seq )
- [ dup length 1- [ nth-pair max , ] with each ] { } make ;
+ [ dup length 1 - [ nth-pair max , ] with each ] { } make ;
! Propagate one row into the upper one
: propagate ( bottom top -- newtop )
PRIVATE>
: alpha-value ( str -- n )
- >lower [ CHAR: a - 1+ ] sigma ;
+ >lower [ CHAR: a - 1 + ] sigma ;
: cartesian-product ( seq1 seq2 -- seq1xseq2 )
[ [ 2array ] with map ] curry map concat ;
[ dup 0 = not ] [ 10 /mod ] produce reverse nip ;
: number-length ( n -- m )
- log10 floor 1+ >integer ;
+ log10 floor 1 + >integer ;
: nth-prime ( n -- n )
- 1- lprimes lnth ;
+ 1 - lprimes lnth ;
: nth-triangle ( n -- n )
- dup 1+ * 2 / ;
+ dup 1 + * 2 / ;
: palindrome? ( n -- ? )
number>string dup reverse = ;
number>string natural-sort >string "123456789" = ;
: pentagonal? ( n -- ? )
- dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
+ dup 0 > [ 24 * 1 + sqrt 1 + 6 / 1 mod zero? ] [ drop f ] if ;
: penultimate ( seq -- elt )
dup length 2 - swap nth ;
! The divisor function, counts the number of divisors
: tau ( m -- n )
- group-factors flip second 1 [ 1+ * ] reduce ;
+ group-factors flip second 1 [ 1 + * ] reduce ;
! Optimized brute-force, is often faster than prime factorization
: tau* ( m -- n )
- factor-2s dup [ 1+ ]
+ factor-2s dup [ 1 + ]
[ perfect-square? -1 0 ? ]
[ dup sqrt >fixnum [1,b] ] tri* [
dupd divisor? [ [ 2 + ] dip ] when
] take-until :> found
growing sequence sequence= [
found dup length
- growing length 1- - head
+ growing length 1 - - head
sequence-parser [ growing length - 1 + ] change-n drop
! sequence-parser advance drop
] [
[ lengths>> ns ] [ nip sequences>> ] 2bi ;
:: (carry-n) ( ns lengths i -- )
- ns length i 1+ = [
+ ns length i 1 + = [
i ns nth i lengths nth = [
0 i ns set-nth
- i 1+ ns [ 1+ ] change-nth
- ns lengths i 1+ (carry-n)
+ i 1 + ns [ 1 + ] change-nth
+ ns lengths i 1 + (carry-n)
] when
] unless ;
0 (carry-n) ;
: product-iter ( ns lengths -- )
- [ 0 over [ 1+ ] change-nth ] dip carry-ns ;
+ [ 0 over [ 1 + ] change-nth ] dip carry-ns ;
: start-product-iter ( sequence-product -- ns lengths )
[ [ drop 0 ] map ] [ [ length ] map ] bi ;
0 :> i!
sequences [ length ] [ * ] map-reduce sequences
[| result |
- sequences [ quot call i result set-nth i 1+ i! ] product-each
+ sequences [ quot call i result set-nth i 1 + i! ] product-each
result
] new-like ; inline
[ first3 ] dip head 3array ;
: strip-tease ( data -- seq )
- dup third length 1- [
+ dup third length 1 - [
2 + (strip-tease)
] with map ;
[ lexenv self>> suffix ] dip <lambda> ;
: compile-method-body ( lexenv block -- quot )
- [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] 2keep
+ [ [ (compile-method-body) ] [ arguments>> length 1 + ] bi ] 2keep
make-return ;
: compile-method ( lexenv ast-method -- )
: compile-smalltalk ( statement -- quot )
[ empty-lexenv ] dip [ compile-sequence nip 0 ]
- 2keep make-return ;
\ No newline at end of file
+ 2keep make-return ;
[ host>> = ] with partition ;
: add-spidered ( spider spider-result -- )
- [ [ 1+ ] change-count ] dip
+ [ [ 1 + ] change-count ] dip
2dup [ spidered>> ] [ dup url>> ] bi* rot set-at
[ filter-base-links ] 2keep
- depth>> 1+ swap
+ depth>> 1 + swap
[ add-nonmatching ]
[ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
DEFER: search
: assume ( n x y -- )
- [ >board ] 2keep [ [ 1+ ] dip search ] 2keep f>board ;
+ [ >board ] 2keep [ [ 1 + ] dip search ] 2keep f>board ;
: attempt ( n x y -- )
{
[ assume ]
} cond ;
-: solve ( x y -- ) 9 [ 1+ 2over attempt ] each 2drop ;
+: solve ( x y -- ) 9 [ 1 + 2over attempt ] each 2drop ;
: board. ( board -- )
standard-table-style [
: search ( x y -- )
{
- { [ over 9 = ] [ [ drop 0 ] dip 1+ search ] }
+ { [ over 9 = ] [ [ drop 0 ] dip 1 + search ] }
{ [ over 0 = over 9 = and ] [ 2drop solution. ] }
- { [ 2dup board> ] [ [ 1+ ] dip search ] }
+ { [ 2dup board> ] [ [ 1 + ] dip search ] }
[ solve ]
} cond ;
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
: computer-name ( -- string )
- MAX_COMPUTERNAME_LENGTH 1+
+ MAX_COMPUTERNAME_LENGTH 1 +
[ <byte-array> dup ] keep <uint>
GetComputerName win32-error=0/f alien>native-string ;
destructors grid-meshes ;
IN: terrain
-CONSTANT: FOV $[ 2.0 sqrt 1+ ]
+CONSTANT: FOV $[ 2.0 sqrt 1 + ]
CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
CONSTANT: FAR-PLANE 2.0
CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
[ not ] change-paused? drop ;
: level>> ( tetris -- level )
- rows>> 1+ 10 / ceiling ;
+ rows>> 1 + 10 / ceiling ;
: update-interval ( tetris -- interval )
- level>> 1- 60 * 1000 swap - ;
+ level>> 1 - 60 * 1000 swap - ;
: add-block ( tetris block -- )
over board>> spin current-piece tetromino>> colour>> set-block ;
{ 2 [ 100 ] }
{ 3 [ 300 ] }
{ 4 [ 1200 ] }
- } case swap 1+ * ;
+ } case swap 1 + * ;
: add-score ( tetris n-rows -- tetris )
over level>> swap rows-score swap [ + ] change-score ;
tetrominoes get random ;
: blocks-max ( blocks quot -- max )
- map [ 1+ ] [ max ] map-reduce ; inline
+ map [ 1 + ] [ max ] map-reduce ; inline
: blocks-width ( blocks -- width )
[ first ] blocks-max ;
: go-left? ( -- ? ) current-side get left eq? ;
-: inc-count ( tree -- ) [ 1+ ] change-count drop ;
+: inc-count ( tree -- ) [ 1 + ] change-count drop ;
-: dec-count ( tree -- ) [ 1- ] change-count drop ;
+: dec-count ( tree -- ) [ 1 - ] change-count drop ;
: node-link@ ( node ? -- node )
go-left? xor [ left>> ] [ right>> ] if ;
list-theme ;
: calc-bounded-index ( n list -- m )
- control-value length 1- min 0 max ;
+ control-value length 1 - min 0 max ;
: bound-index ( list -- )
dup index>> over calc-bounded-index >>index drop ;
] if ;
: select-previous ( list -- )
- [ index>> 1- ] keep select-index ;
+ [ index>> 1 - ] keep select-index ;
: select-next ( list -- )
- [ index>> 1+ ] keep select-index ;
+ [ index>> 1 + ] keep select-index ;
: invoke-value-action ( list -- )
dup list-empty? [
*wordtimes* get-global [ drop { 0 0 } ] cache first2 ;
: update-times ( utime current-utime current-numinvokes -- utime' invokes' )
- rot [ + ] curry [ 1+ ] bi* ;
+ rot [ + ] curry [ 1 + ] bi* ;
: register-time ( utime word -- )
name>>
projects / factor.git / commitdiff