"." write flush
{
- new-sequence nth push pop peek flip
+ new-sequence nth push pop last flip
} compile-unoptimized
"." write flush
[
"\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d"
] [
- 16 11 <string> "Hi There" md5 hmac-bytes >string ] unit-test
+ "Hi There" 16 11 <string> md5 hmac-bytes >string ] unit-test
[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ]
-[ "Jefe" "what do ya want for nothing?" md5 hmac-bytes >string ] unit-test
+[ "what do ya want for nothing?" "Jefe" md5 hmac-bytes >string ] unit-test
[
"V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6"
]
[
- 16 HEX: aa <string>
- 50 HEX: dd <repetition> md5 hmac-bytes >string
+ 50 HEX: dd <repetition>
+ 16 HEX: aa <string> md5 hmac-bytes >string
] unit-test
[
"g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
] [
- 16 11 <string> "Hi There" sha1 hmac-bytes >string
+ "Hi There" 16 11 <string> sha1 hmac-bytes >string
] unit-test
[
"\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y"
] [
- "Jefe" "what do ya want for nothing?" sha1 hmac-bytes >string
+ "what do ya want for nothing?" "Jefe" sha1 hmac-bytes >string
] unit-test
[
"\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb"
] [
- 16 HEX: aa <string>
- 50 HEX: dd <repetition> sha1 hmac-bytes >string
+ 50 HEX: dd <repetition>
+ 16 HEX: aa <string> sha1 hmac-bytes >string
] unit-test
[ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ]
-[ 20 HEX: b <string> "Hi There" sha-256 hmac-bytes hex-string ] unit-test
+[ "Hi There" 20 HEX: b <string> sha-256 hmac-bytes hex-string ] unit-test
[ "167f928588c5cc2eef8e3093caa0e87c9ff566a14794aa61648d81621a2a40c6" ]
[
- "JefeJefeJefeJefeJefeJefeJefeJefe"
- "what do ya want for nothing?" sha-256 hmac-bytes hex-string
+ "what do ya want for nothing?"
+ "JefeJefeJefeJefeJefeJefeJefeJefe" sha-256 hmac-bytes hex-string
] unit-test
: ipad ( checksum-state -- seq ) block-size>> HEX: 36 <array> ;
-:: init-K ( K checksum checksum-state -- o i )
- checksum-state block-size>> K length <
- [ K checksum checksum-bytes ] [ K ] if
+:: init-key ( checksum key checksum-state -- o i )
+ checksum-state block-size>> key length <
+ [ key checksum checksum-bytes ] [ key ] if
checksum-state block-size>> 0 pad-tail
[ checksum-state opad seq-bitxor ]
[ checksum-state ipad seq-bitxor ] bi ;
PRIVATE>
-:: hmac-stream ( K stream checksum -- value )
- K checksum dup initialize-checksum-state
- dup :> checksum-state
- init-K :> Ki :> Ko
+:: hmac-stream ( stream key checksum -- value )
+ checksum initialize-checksum-state :> checksum-state
+ checksum key checksum-state init-key :> Ki :> Ko
checksum-state Ki add-checksum-bytes
stream add-checksum-stream get-checksum
checksum initialize-checksum-state
Ko add-checksum-bytes swap add-checksum-bytes
get-checksum ;
-: hmac-file ( K path checksum -- value )
- [ binary <file-reader> ] dip hmac-stream ;
+: hmac-file ( path key checksum -- value )
+ [ binary <file-reader> ] 2dip hmac-stream ;
-: hmac-bytes ( K seq checksum -- value )
- [ binary <byte-reader> ] dip hmac-stream ;
+: hmac-bytes ( seq key checksum -- value )
+ [ binary <byte-reader> ] 2dip hmac-stream ;
: full? ( circular -- ? )
[ length ] [ seq>> length ] bi = ;
-: set-peek ( elt seq -- )
+: set-last ( elt seq -- )
[ length 1- ] keep set-nth ;
PRIVATE>
: push-growing-circular ( elt circular -- )
dup full? [ push-circular ]
- [ [ 1+ ] change-length set-peek ] if ;
+ [ [ 1+ ] change-length set-last ] if ;
: <growing-circular> ( capacity -- growing-circular )
{ } new-sequence 0 0 growing-circular boa ;
: record-constant-set-slot ( slot# vreg -- )
history [
- dup empty? [ dup peek store? [ dup pop* ] when ] unless
+ dup empty? [ dup last store? [ dup pop* ] when ] unless
store new-action swap ?push
] change-at ;
[ second ds-load ] [ ^^load-literal ] bi prefix ;
: emit-<tuple-boa> ( node -- )
- dup node-input-infos peek literal>>
+ dup node-input-infos last literal>>
dup array? [
nip
ds-drop
: >node ( cursor -- ) node-stack get push ;
: node> ( -- cursor ) node-stack get pop ;
-: node@ ( -- cursor ) node-stack get peek ;
+: node@ ( -- cursor ) node-stack get last ;
: current-node ( -- node ) node@ first ;
: iterate-next ( -- cursor ) node@ rest-slice ;
: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
[ split-children ] map concat check-assigned ;
: picture ( uses -- str )
- dup peek 1 + CHAR: space <string>
+ dup last 1 + CHAR: space <string>
[ '[ CHAR: * swap _ set-nth ] each ] keep ;
: interval-picture ( interval -- str )
swap int-regs swap vreg boa >>vreg
max-uses get random 2 max [ not-taken ] replicate natural-sort
[ >>uses ] [ first >>start ] bi
- dup uses>> peek >>end
+ dup uses>> last >>end
] map
] with-scope ;
: delete-conditional? ( bb -- ? )
dup instructions>> [ drop f ] [
- peek class {
+ last class {
##compare-branch
##compare-imm-branch
##compare-float-branch
: remove-phi-inputs ( #phi -- )
if-node get children>>
- [ dup ends-with-terminate? [ drop f ] [ peek out-d>> ] if ] map
+ [ dup ends-with-terminate? [ drop f ] [ last out-d>> ] if ] map
pad-with-bottom >>phi-in-d drop ;
: live-value-indices ( values -- indices )
propagate
compute-def-use
dup check-nodes
- peek node-input-infos ;
+ last node-input-infos ;
: final-classes ( quot -- seq )
final-info [ class>> ] map ;
C: --> implication
: assume-implication ( p q -- )
- [ constraints get [ assoc-stack swap suffix ] 2keep peek set-at ]
+ [ constraints get [ assoc-stack swap suffix ] 2keep last set-at ]
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
M: implication assume*
resolve-copy value-infos get assoc-stack null-info or ;
: set-value-info ( info value -- )
- resolve-copy value-infos get peek set-at ;
+ resolve-copy value-infos get last set-at ;
: refine-value-info ( info value -- )
resolve-copy value-infos get
[ assoc-stack value-info-intersect ] 2keep
- peek set-at ;
+ last set-at ;
: value-literal ( value -- obj ? )
value-info >literal< ;
dup in-d>> first node-value-info literal>> ;
: last-literal ( #call -- obj )
- dup out-d>> peek node-value-info literal>> ;
+ dup out-d>> last node-value-info literal>> ;
: immutable-tuple-boa? ( #call -- ? )
dup word>> \ <tuple-boa> eq? [
- dup in-d>> peek node-value-info
+ dup in-d>> last node-value-info
literal>> first immutable-tuple-class?
] [ drop f ] if ;
{ fixnum byte-array } declare
[ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
[ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift
- 255 min 0 max
+ 0 255 clamp
] final-classes
] unit-test
] unit-test
[ V{ 1.5 } ] [
- [ /f 1.5 min 1.5 max ] final-literals
+ [ /f 1.5 1.5 clamp ] final-literals
] unit-test
[ V{ 1.5 } ] [
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
! Joe found an oversight
-[ V{ integer } ] [ [ >integer ] final-classes ] unit-test
\ No newline at end of file
+[ V{ integer } ] [ [ >integer ] final-classes ] unit-test
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
: ends-with-terminate? ( nodes -- ? )
- [ f ] [ peek #terminate? ] if-empty ;
+ [ f ] [ last #terminate? ] if-empty ;
M: vector child-visitor V{ } clone ;
M: vector #introduce, #introduce node, ;
[ first2 get-process send ] [ stop-this-server ] if* ;
: <node-server> ( addrspec -- threaded-server )
- <threaded-server>
+ binary <threaded-server>
swap >>insecure
- binary >>encoding
"concurrency.distributed" >>name
[ handle-node-client ] >>handler ;
}
: font-name ( string -- string' )
- font-names at-default ;
+ font-names ?at drop ;
: (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline
4 "double" c-type (>>align)
] unless
-FUNCTION: bool check_sse2 ( ) ;
-
-: sse2? ( -- ? )
- check_sse2 ;
+USING: cpu.x86.features cpu.x86.features.private ;
"-no-sse2" (command-line) member? [
[ { check_sse2 } compile ] with-optimizer
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: cpu.x86.features.tests
+USING: cpu.x86.features tools.test kernel sequences math system ;
+
+cpu x86? [
+ [ t ] [ sse2? { t f } member? ] unit-test
+ [ t ] [ [ 10000 [ ] times ] count-instructions integer? ] unit-test
+] when
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system kernel math alien.syntax ;
+IN: cpu.x86.features
+
+<PRIVATE
+
+FUNCTION: bool check_sse2 ( ) ;
+
+FUNCTION: longlong read_timestamp_counter ( ) ;
+
+PRIVATE>
+
+HOOK: sse2? cpu ( -- ? )
+
+M: x86.32 sse2? check_sse2 ;
+
+M: x86.64 sse2? t ;
+
+HOOK: instruction-count cpu ( -- n )
+
+M: x86 instruction-count read_timestamp_counter ;
+
+: count-instructions ( quot -- n )
+ instruction-count [ call ] dip instruction-count swap - ; inline
: csv ( stream -- rows )
[ [ (csv) ] { } make ] with-input-stream
- dup peek { "" } = [ but-last ] when ;
+ dup last { "" } = [ but-last ] when ;
: file>csv ( path encoding -- csv )
<file-reader> csv ;
[ "Goodbye, cruel world." ] [ "d" get doc-string ] unit-test
[ "" { 0 9 } { 0 15 } ] [
- "d" get undos>> peek
+ "d" get undos>> last
[ old-string>> ] [ from>> ] [ new-to>> ] tri
] unit-test
[ ] [ "Hello world" "d" get set-doc-string ] unit-test
-[ { "" } ] [ "value" get ] unit-test
\ No newline at end of file
+[ { "" } ] [ "value" get ] unit-test
] [
first swap length 1- + 0
] if
- ] dip peek length + 2array ;
+ ] dip last length + 2array ;
: prepend-first ( str seq -- )
0 swap [ append ] change-nth ;
[ undos>> ] [ redos>> ] [ undo-edit ] undo/redo ;
: redo ( document -- )
- [ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ;
\ No newline at end of file
+ [ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ;
: trim-row ( seq -- seq' )
rest
- dup peek empty? [ but-last ] when ;
+ dup last empty? [ but-last ] when ;
-: ?peek ( seq -- elt/f )
- [ f ] [ peek ] if-empty ;
+: ?last ( seq -- elt/f )
+ [ f ] [ last ] if-empty ;
: coalesce ( rows -- rows' )
V{ } clone [
'[
- _ dup ?peek ?peek CHAR: \\ =
+ _ dup ?last ?last CHAR: \\ =
[ [ pop "|" rot 3append ] keep ] when
push
] each
] with-destructors ;
: <ftp-server> ( directory port -- server )
- ftp-server new-threaded-server
+ latin1 ftp-server new-threaded-server
swap >>insecure
swap canonicalize-path >>serving-directory
"ftp.server" >>name
- 5 minutes >>timeout
- latin1 >>encoding ;
+ 5 minutes >>timeout ;
: ftpd ( directory port -- )
<ftp-server> start-server ;
MACRO: nspread ( quots n -- )
over empty? [ 2drop [ ] ] [
[ [ but-last ] dip ]
- [ [ peek ] dip ] 2bi
+ [ [ last ] dip ] 2bi
swap
'[ [ _ _ nspread ] _ ndip @ ]
] if ;
data>> pop* ; inline
: data-peek ( heap -- entry )
- data>> peek ; inline
+ data>> last ; inline
: data-first ( heap -- entry )
data>> first ; inline
[ (eval>string) ] call( code -- output )
"\n" ?tail drop
] keep
- peek assert=
+ last assert=
] vocabs-quot get call( quot -- ) ;
: check-examples ( element -- )
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser words definitions kernel sequences assocs arrays
-kernel.private fry combinators accessors vectors strings sbufs
-byte-arrays byte-vectors io.binary io.streams.string splitting math
-math.parser generic generic.single generic.standard classes
-hashtables namespaces ;
+USING: accessors arrays assocs byte-arrays byte-vectors classes
+combinators definitions fry generic generic.single
+generic.standard hashtables io.binary io.streams.string kernel
+kernel.private math math.parser namespaces parser sbufs
+sequences splitting splitting.private strings vectors words ;
IN: hints
GENERIC: specializer-predicate ( spec -- quot )
{ first first2 first3 first4 }
[ { array } "specializer" set-word-prop ] each
-{ peek pop* pop } [
+{ last pop* pop } [
{ vector } "specializer" set-word-prop
] each
'space' ,
'attr' ,
'space' ,
- [ "=" token , 'space' , 'value' , ] seq* [ peek ] action optional ,
+ [ "=" token , 'space' , 'value' , ] seq* [ last ] action optional ,
'space' ,
] seq* ;
] with-destructors ;
: <http-server> ( -- server )
- http-server new-threaded-server
+ ascii http-server new-threaded-server
"http.server" >>name
"http" protocol-port >>insecure
"https" protocol-port >>secure ;
: &back ( -- )
inspector-stack get
- dup length 1 <= [ drop ] [ [ pop* ] [ peek reinspect ] bi ] if ;
+ dup length 1 <= [ drop ] [ [ pop* ] [ last reinspect ] bi ] if ;
: &add ( value key -- ) mirror get set-at &push reinspect ;
\ first4 [ 4array ] define-inverse
\ prefix \ unclip define-dual
-\ suffix [ dup but-last swap peek ] define-inverse
+\ suffix [ dup but-last swap last ] define-inverse
\ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
\ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse
{ $class-description "The class of threaded servers. New instances are created with " { $link <threaded-server> } ". This class may be subclassed, and instances of subclasses should be created with " { $link new-threaded-server } ". See " { $link "server-config" } " for slot documentation." } ;
HELP: new-threaded-server
-{ $values { "class" class } { "threaded-server" threaded-server } }
+{ $values { "encoding" "an encoding descriptor" } { "class" class } { "threaded-server" threaded-server } }
{ $description "Creates a new instance of a subclass of " { $link threaded-server } ". Subclasses can implement the " { $link handle-client* } " generic word." } ;
HELP: <threaded-server>
-{ $values { "threaded-server" threaded-server } }
-{ $description "Creates a new threaded server. Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ;
+{ $values { "encoding" "an encoding descriptor" } { "threaded-server" threaded-server } }
+{ $description "Creates a new threaded server with streams encoded " { $snippet "encoding" } ". Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ;
HELP: remote-address
{ $var-description "Variable holding the address specifier of the current client connection. See " { $link "network-addressing" } "." } ;
io.servers.connection.private kernel accessors sequences
concurrency.promises io.encodings.ascii io threads calendar ;
-[ t ] [ <threaded-server> listen-on empty? ] unit-test
+[ t ] [ ascii <threaded-server> listen-on empty? ] unit-test
[ f ] [
- <threaded-server>
+ ascii <threaded-server>
25 internet-server >>insecure
listen-on
empty?
and
] unit-test
-[ ] [ <threaded-server> init-server drop ] unit-test
+[ ] [ ascii <threaded-server> init-server drop ] unit-test
[ 10 ] [
- <threaded-server>
+ ascii <threaded-server>
10 >>max-connections
init-server semaphore>> count>>
] unit-test
[ ] [
- <threaded-server>
+ ascii <threaded-server>
5 >>max-connections
0 >>insecure
[ "Hello world." write stop-this-server ] >>handler
: internet-server ( port -- addrspec ) f swap <inet> ;
-: new-threaded-server ( class -- threaded-server )
+: new-threaded-server ( encoding class -- threaded-server )
new
+ swap >>encoding
"server" >>name
DEBUG >>log-level
- ascii >>encoding
1 minutes >>timeout
V{ } clone >>sockets
<secure-config> >>secure-config
[ "No handler quotation" throw ] >>handler
<flag> >>ready ; inline
-: <threaded-server> ( -- threaded-server )
+: <threaded-server> ( encoding -- threaded-server )
threaded-server new-threaded-server ;
GENERIC: handle-client* ( threaded-server -- )
\r
: levenshtein ( old new -- n )\r
[ levenshtein-initialize ] [ levenshtein-step ]\r
- run-lcs peek peek ;\r
+ run-lcs last last ;\r
\r
TUPLE: retain item ;\r
TUPLE: delete item ;\r
building get empty? [\r
"Warning: log begins with multiline entry" print drop\r
] [\r
- message>> first building get peek message>> push\r
+ message>> first building get last message>> push\r
] if ;\r
\r
: parse-log ( lines -- entries )\r
] unit-test
[ t ] [
- 1067811677921310779 make-bits peek
+ 1067811677921310779 make-bits last
] unit-test
[ t ] [
- 1067811677921310779 >bignum make-bits peek
-] unit-test
\ No newline at end of file
+ 1067811677921310779 >bignum make-bits last
+] unit-test
"Incrementing, decrementing:"
{ $subsection 1+ }
{ $subsection 1- }
-"Minimum, maximum:"
+"Minimum, maximum, clamping:"
{ $subsection min }
{ $subsection max }
+{ $subsection clamp }
"Complex conjugation:"
{ $subsection conjugate }
"Tests:"
[ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test
[ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test
+[ C{ 1 2 } ] [ C{ 1 2 } 1 ^ ] unit-test
\ No newline at end of file
M: ratio ^n
[ >fraction ] dip [ ^n ] curry bi@ / ;
-M: float ^n
- (^n) ;
+M: float ^n (^n) ;
+
+M: complex ^n (^n) ;
: integer^ ( x y -- z )
dup 0 > [ ^n ] [ neg ^n recip ] if ; inline
: /-last ( seq seq -- a )
#! divide the last two numbers in the sequences
- [ peek ] bi@ / ;
+ [ last ] bi@ / ;
: (p/mod) ( p p -- p p )
2dup /-last
USING: help.syntax help.markup arrays sequences ;
-
IN: math.ranges
ARTICLE: "math.ranges" "Numeric ranges"
{ $code "100 1 [a,b] product" }
"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ;
-ABOUT: "math.ranges"
\ No newline at end of file
+ABOUT: "math.ranges"
[ { 0 1/3 2/3 1 } ] [ 0 1 1/3 <range> >array ] unit-test
[ { 0 1/3 2/3 1 } ] [ 1 0 -1/3 <range> >array reverse ] unit-test
-[ t ] [ 5 [0,b] range-increasing? ] unit-test
-[ f ] [ 5 [0,b] range-decreasing? ] unit-test
-[ f ] [ -5 [0,b] range-increasing? ] unit-test
-[ t ] [ -5 [0,b] range-decreasing? ] unit-test
-[ 0 ] [ 5 [0,b] range-min ] unit-test
-[ 5 ] [ 5 [0,b] range-max ] unit-test
-[ 3 ] [ 3 5 [0,b] clamp-to-range ] unit-test
-[ 0 ] [ -1 5 [0,b] clamp-to-range ] unit-test
-[ 5 ] [ 6 5 [0,b] clamp-to-range ] unit-test
-[ { 0 1 2 3 4 } ] [ 5 sequence-index-range >array ] unit-test
-
[ 100 ] [
1 100 [a,b] [ 2^ [1,b] ] map prune length
-] unit-test
\ No newline at end of file
+] unit-test
INSTANCE: range immutable-sequence
+<PRIVATE
+
: twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline
: (a, ( a b step -- a' b' step ) dup [ + ] curry 2dip ; inline
: ,b) ( a b step -- a' b' step ) dup [ - ] curry dip ; inline
+PRIVATE>
+
: [a,b] ( a b -- range ) twiddle <range> ; inline
: (a,b] ( a b -- range ) twiddle (a, <range> ; inline
: [1,b] ( b -- range ) 1 swap [a,b] ; inline
: [0,b) ( b -- range ) 0 swap [a,b) ; inline
-
-: range-increasing? ( range -- ? )
- step>> 0 > ;
-
-: range-decreasing? ( range -- ? )
- step>> 0 < ;
-
-: first-or-peek ( seq head? -- elt )
- [ first ] [ peek ] if ;
-
-: range-min ( range -- min )
- dup range-increasing? first-or-peek ;
-
-: range-max ( range -- max )
- dup range-decreasing? first-or-peek ;
-
-: clamp-to-range ( n range -- n )
- [ range-min max ] [ range-max min ] bi ;
-
-: sequence-index-range ( seq -- range )
- length [0,b) ;
[ 2 ] [ { 1 2 3 } median ] unit-test
[ 5/2 ] [ { 1 2 3 4 } median ] unit-test
+[ 1 ] [ { 1 } mode ] unit-test
+[ 3 ] [ { 1 2 3 3 3 4 5 6 76 7 2 21 1 3 3 3 } mode ] unit-test
+
[ { } median ] must-fail
[ { } upper-median ] must-fail
[ { } lower-median ] must-fail
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel math math.analysis
math.functions math.order sequences sorting locals
-sequences.private ;
+sequences.private assocs fry ;
IN: math.statistics
: mean ( seq -- x )
: median ( seq -- x )
dup length odd? [ lower-median ] [ medians + 2 / ] if ;
+: frequency ( seq -- hashtable )
+ H{ } clone [ '[ _ inc-at ] each ] keep ;
+
+: mode ( seq -- x )
+ frequency >alist
+ [ ] [ [ [ second ] bi@ > ] 2keep ? ] map-reduce first ;
+
: minmax ( seq -- min max )
#! find the min and max of a seq in one pass
[ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ;
GENERIC: set-range-max-value ( value model -- )
: clamp-value ( value range -- newvalue )
- [ range-min-value max ] keep
- range-max-value* min ;
+ [ range-min-value ] [ range-max-value* ] bi clamp ;
] bind ;\r
\r
M: ebnf (transform) ( ast -- parser )\r
- rules>> [ (transform) ] map peek ;\r
+ rules>> [ (transform) ] map last ;\r
\r
M: ebnf-tokenizer (transform) ( ast -- parser )\r
elements>> dup "default" = [\r
dup level>> 1 = [
new-child
] [
- tuck children>> peek (ppush-new-tail)
+ tuck children>> last (ppush-new-tail)
[ swap new-child ] [ swap node-set-last f ] ?if
] if ;
: ppop-contraction ( node -- node' tail' )
dup children>> length 1 =
- [ children>> peek f swap ]
+ [ children>> last f swap ]
[ (ppop-contraction) ]
if ;
: (ppop-new-tail) ( root -- root' tail' )
dup level>> 1 > [
- dup children>> peek (ppop-new-tail) [
+ dup children>> last (ppop-new-tail) [
dup
[ swap node-set-last ]
[ drop ppop-contraction drop ]
: consonant-end? ( n seq -- ? )
[ length swap - ] keep consonant? ;
-: last-is? ( str possibilities -- ? ) [ peek ] dip member? ;
+: last-is? ( str possibilities -- ? ) [ last ] dip member? ;
: cvc? ( str -- ? )
{
pick consonant-seq 0 > [ nip ] [ drop ] if append ;
: step1a ( str -- newstr )
- dup peek CHAR: s = [
+ dup last CHAR: s = [
{
{ [ "sses" ?tail ] [ "ss" append ] }
{ [ "ies" ?tail ] [ "i" append ] }
[ 1 = [ but-last-slice cvc? not ] [ drop f ] if ] if ;
: remove-e ( str -- newstr )
- dup peek CHAR: e = [
+ dup last CHAR: e = [
dup remove-e? [ but-last-slice ] when
] when ;
: ll->l ( str -- newstr )
{
- { [ dup peek CHAR: l = not ] [ ] }
+ { [ dup last CHAR: l = not ] [ ] }
{ [ dup length 1- over double-consonant? not ] [ ] }
{ [ dup consonant-seq 1 > ] [ but-last-slice ] }
[ ]
: <block> ( style -- block )
block new-block ;
-: pprinter-block ( -- block ) pprinter-stack get peek ;
+: pprinter-block ( -- block ) pprinter-stack get last ;
: add-section ( section -- )
pprinter-block sections>> push ;
! Long section layout algorithm
: chop-break ( seq -- seq )
- dup peek line-break? [ but-last-slice chop-break ] when ;
+ dup last line-break? [ but-last-slice chop-break ] when ;
SYMBOL: prev
SYMBOL: next
] { } make { t } split harvest ;
: break-group? ( seq -- ? )
- [ first section-fits? ] [ peek section-fits? not ] bi and ;
+ [ first section-fits? ] [ last section-fits? not ] bi and ;
: ?break-group ( seq -- )
dup break-group? [ first <fresh-line ] [ drop ] if ;
] with-scope ; inline
: with-pprint ( obj quot -- )
- make-pprint drop do-pprint ; inline
\ No newline at end of file
+ make-pprint drop do-pprint ; inline
[ 1 ] [ message >quoted string-lines length ] unit-test
[ t ] [ message >quoted-lines "=\r\n" swap subseq? ] unit-test
[ 4 ] [ message >quoted-lines string-lines length ] unit-test
-[ "===o" ] [ message >quoted-lines string-lines [ peek ] "" map-as ] unit-test
+[ "===o" ] [ message >quoted-lines string-lines [ last ] "" map-as ] unit-test
{
[ length 1 > ]
[ first quote? ]
- [ [ first ] [ peek ] bi = ]
+ [ [ first ] [ last ] bi = ]
} 1&& ;
: unquote ( str -- newstr )
- dup quoted? [ but-last-slice rest-slice >string ] when ;
\ No newline at end of file
+ dup quoted? [ but-last-slice rest-slice >string ] when ;
-USING: sorting.human tools.test sorting.slots ;
+USING: sorting.human tools.test sorting.slots sorting ;
IN: sorting.human.tests
-[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test
+[ { "x1y" "x2" "x10y" } ]
+[ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test
+
+[ { "4dup" "nip" } ]
+[ { "4dup" "nip" } [ human<=> ] sort ] unit-test
+
+[ { "4dup" "nip" } ]
+[ { "nip" "4dup" } [ human<=> ] sort ] unit-test
+
+[ { "4dup" "4nip" "5drop" "nip" "nip2" "nipd" } ]
+[ { "nip" "4dup" "4nip" "5drop" "nip2" "nipd" } [ human<=> ] sort ] unit-test
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.parser peg.ebnf sorting.functor ;
+USING: accessors kernel math math.order math.parser peg.ebnf
+sequences sorting.functor ;
IN: sorting.human
: find-numbers ( string -- seq )
[EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
-<< "human" [ find-numbers ] define-sorting >>
+! For comparing integers or sequences
+TUPLE: hybrid obj ;
+
+M: hybrid <=>
+ [ obj>> ] bi@
+ 2dup [ integer? ] bi@ xor [
+ drop integer? [ +lt+ ] [ +gt+ ] if
+ ] [
+ <=>
+ ] if ;
+
+<< "human" [ find-numbers [ hybrid boa ] map ] define-sorting >>
"The Beatles"
"A river runs through it"
"Another"
+ "The"
+ "A"
+ "Los"
"la vida loca"
"Basketball"
"racquetball"
} ;
[
{
+ "A"
"Another"
"Basketball"
"The Beatles"
"for the horde"
"Los Fujis"
"los Fujis"
+ "Los"
"of mice and men"
"on belay"
"racquetball"
"A river runs through it"
+ "The"
"la vida loca"
}
] [
unicode.case ;
IN: sorting.title
-<< "title" [ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match [ to>> tail-slice ] when* ] define-sorting >>
+<< "title" [
+ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match
+ [ to>> tail-slice ] when*
+] define-sorting >>
<PRIVATE
-: ,, ( obj -- ) building get peek push ;
+: ,, ( obj -- ) building get last push ;
: v, ( -- ) V{ } clone , ;
-: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
+: ,v ( -- ) building get dup last empty? [ dup pop* ] when drop ;
: (monotonic-split) ( seq quot -- newseq )
[
[
[ no-case ]
] [
- dup peek callable? [
- dup peek swap but-last
+ dup last callable? [
+ dup last swap but-last
] [
[ no-case ] swap
] if case>quot
{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } }
{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ;
-HELP: annotate-methods
-{ $values
- { "word" word } { "quot" quotation } }
-{ $description "Annotates the word -- for generic words, all its methods -- with the quotation." } ;
-
HELP: reset
{ $values
{ "word" word } }
[ "" ] [ [ 3 another-generic drop ] with-string-writer ] unit-test
+! reset should do the right thing for generic words
+[ ] [ \ another-generic watch ] unit-test
+
GENERIC: blah-generic ( a -- b )
M: string blah-generic ;
GENERIC: reset ( word -- )
M: generic reset
- [ call-next-method ]
- [ subwords [ reset ] each ] bi ;
+ subwords [ reset ] each ;
M: word reset
dup "unannotated-def" word-prop [
ERROR: cannot-annotate-twice word ;
+M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ;
+
<PRIVATE
: check-annotate-twice ( word -- word )
cannot-annotate-twice
] when ;
-: save-unannotated-def ( word -- )
- dup def>> "unannotated-def" set-word-prop ;
+PRIVATE>
-: (annotate) ( word quot -- )
- [ dup def>> ] dip call( old -- new ) define ;
+GENERIC# annotate 1 ( word quot -- )
-PRIVATE>
+M: generic annotate
+ [ "methods" word-prop values ] dip '[ _ annotate ] each ;
-: annotate ( word quot -- )
+M: word annotate
[ check-annotate-twice ] dip
- [ over save-unannotated-def (annotate) ] with-compilation-unit ;
+ [
+ [ dup def>> 2dup "unannotated-def" set-word-prop ] dip
+ call( old -- new ) define
+ ] with-compilation-unit ;
<PRIVATE
: watch-vars ( word vars -- )
dupd '[ [ _ _ ] dip (watch-vars) ] annotate ;
-GENERIC# annotate-methods 1 ( word quot -- )
-
-M: generic annotate-methods
- [ "methods" word-prop values ] dip [ annotate ] curry each ;
-
-M: word annotate-methods
- annotate ;
-
: breakpoint ( word -- )
- [ add-breakpoint ] annotate-methods ;
+ [ add-breakpoint ] annotate ;
: breakpoint-if ( word quot -- )
- '[ [ _ [ [ break ] when ] ] dip 3append ] annotate-methods ;
+ '[ [ _ [ [ break ] when ] ] dip 3append ] annotate ;
SYMBOL: word-timing
2dup number=
[ drop ] [ nip V{ } clone pick push ] if
1+
- ] keep pick peek push
+ ] keep pick last push
] each ;
: runs ( seq -- newseq )
all-vocabs-seq name-completions ;
: chars-matching ( str -- seq )
- name-map keys dup zip completions ;
\ No newline at end of file
+ name-map keys dup zip completions ;
[ t ] [ B{ } hexdump "Length: 0, 0h\n" = ] unit-test
[ t ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test
-[ t ] [ 256 [ ] B{ } map-as hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
+[ t ] [ 256 iota [ ] B{ } map-as hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
[
dup { 0 0 } = [
drop
windows get length 1 <= [ -> center ] [
- windows get peek second window-loc>>
+ windows get last second window-loc>>
dupd first2 <CGPoint> -> cascadeTopLeftFromPoint:
-> setFrameTopLeftPoint:
] if
: fix-sigma-end ( string -- string )
[ "" ] [
- dup peek CHAR: greek-small-letter-sigma =
+ dup last CHAR: greek-small-letter-sigma =
[ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when
] if-empty ; inline
[ drop { } ]\r
[ [ AAAA ] [ BBBB ] bi 2array ] if ;\r
\r
-: last ( -- char )\r
- building get empty? [ 0 ] [ building get peek peek ] if ;\r
+: building-last ( -- char )\r
+ building get empty? [ 0 ] [ building get last last ] if ;\r
\r
: blocked? ( char -- ? )\r
combining-class dup { 0 f } member?\r
- [ drop last non-starter? ]\r
- [ last combining-class = ] if ;\r
+ [ drop building-last non-starter? ]\r
+ [ building-last combining-class = ] if ;\r
\r
: possible-bases ( -- slice-of-building )\r
building get dup [ first non-starter? not ] find-last\r
: name>char ( name -- char ) name-map at ; inline
: char>name ( char -- name ) name-map value-at ; inline
: property? ( char property -- ? ) properties at interval-key? ; inline
-: ch>lower ( ch -- lower ) simple-lower at-default ; inline
-: ch>upper ( ch -- upper ) simple-upper at-default ; inline
-: ch>title ( ch -- title ) simple-title at-default ; inline
+: ch>lower ( ch -- lower ) simple-lower ?at drop ; inline
+: ch>upper ( ch -- upper ) simple-upper ?at drop ; inline
+: ch>title ( ch -- title ) simple-title ?at drop ; inline
: special-case ( ch -- casing-tuple ) special-casing at ; inline
! For non-existent characters, use Cn
[ "foo" VL{ "hi" "there" } t ]
[
VL{ "hi" "there" "foo" } dup "v" set
- [ peek ] [ ppop ] bi
+ [ last ] [ ppop ] bi
dup "v" get [ vector>> ] bi@ eq?
] unit-test
{ "sans-serif" "Tahoma" }\r
{ "serif" "Times New Roman" }\r
{ "monospace" "Courier New" }\r
- } at-default ;\r
+ } ?at drop ;\r
\r
MEMO:: (cache-font) ( font -- HFONT )\r
font size>> neg ! nHeight\r
<PRIVATE
: add-child ( object -- )
- xml-stack get peek second push ;
+ xml-stack get last second push ;
: push-xml ( object -- )
V{ } clone 2array xml-stack get push ;
CYGWIN_NT-5.2-WOW64) OS=winnt;;
*CYGWIN_NT*) OS=winnt;;
*CYGWIN*) OS=winnt;;
+ MINGW32*) OS=winnt;;
*darwin*) OS=macosx;;
*Darwin*) OS=macosx;;
*linux*) OS=linux;;
{ $see-also at* assoc-size } ;
ARTICLE: "assocs-values" "Transposed assoc operations"
-"Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:"
+"default Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:"
{ $subsection value-at }
{ $subsection value-at* }
{ $subsection value? }
{ $subsection assoc-any? }
{ $subsection assoc-all? }
"Additional combinators:"
+{ $subsection assoc-partition }
{ $subsection cache }
+{ $subsection 2cache }
{ $subsection map>assoc }
{ $subsection assoc>map }
{ $subsection assoc-map-as } ;
{ assoc-filter assoc-filter-as } related-words
+HELP: assoc-partition
+{ $values
+ { "assoc" assoc } { "quot" quotation }
+ { "true-assoc" assoc } { "false-assoc" assoc }
+}
+{ $description "Calls a predicate quotation on each key of the input assoc. If the test yields true, the key/value pair is added to " { $snippet "true-assoc" } "; if false, it's added to " { $snippet "false-assoc" } "." } ;
+
HELP: assoc-any?
{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;
HELP: cache
{ $values { "key" "a key" } { "assoc" assoc } { "quot" { $quotation "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
-{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc." }
+{ $description "If the key is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the key/value pair into the assoc. Returns a value either looked up or newly stored in the assoc." }
+{ $side-effects "assoc" } ;
+
+HELP: 2cache
+{ $values { "key1" "a key" } { "key2" "a key" } { "assoc" assoc } { "quot" { $quotation "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
+{ $description "If a single key composed of the input keys is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the keys/value pair into the assoc. Returns the value stored in the assoc. Returns a value either looked up or newly stored in the assoc." }
{ $side-effects "assoc" } ;
HELP: map>assoc
} extract-keys
] unit-test
-[ f ] [
- "a" H{ { "a" f } } at-default
-] unit-test
-
-[ "b" ] [
- "b" H{ { "a" f } } at-default
-] unit-test
-
-[ "x" ] [
- "a" H{ { "a" "x" } } at-default
-] unit-test
-
[ H{ { "b" [ 2 ] } { "d" [ 4 ] } } H{ { "a" [ 1 ] } { "c" [ 3 ] } } ] [
H{
{ "a" [ 1 ] }
: at ( key assoc -- value/f )
at* drop ; inline
-: at-default ( key assoc -- value/key )
- ?at drop ; inline
-
M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ dup assoc-size ] dip new-assoc
[ [ set-at ] with-assoc assoc-each ] keep ;
: min-class ( class seq -- class/f )\r
over [ classes-intersect? ] curry filter\r
[ drop f ] [\r
- [ nip ] [ [ class<= ] with all? ] 2bi [ peek ] [ drop f ] if\r
+ [ nip ] [ [ class<= ] with all? ] 2bi [ last ] [ drop f ] if\r
] if-empty ;\r
\r
GENERIC: (flatten-class) ( class -- )\r
: save-class-location ( class -- )
location remember-class ;
-: create-class-in ( word -- word )
+: create-class-in ( string -- word )
current-vocab create
dup save-class-location
dup predicate-word dup set-word save-location ;
USING: alien strings kernel math tools.test io prettyprint
namespaces combinators words classes sequences accessors
-math.functions arrays ;
+math.functions arrays combinators.private ;
IN: combinators.tests
[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
[ \ drop prefix ] bi*
] assoc-map alist>quot ;
+<PRIVATE
+
: (distribute-buckets) ( buckets pair keys -- )
dup t eq? [
drop [ swap adjoin ] curry each
] [ ] make , , \ if ,
] [ ] make ;
+PRIVATE>
+
: case>quot ( default assoc -- quot )
dup keys {
{ [ dup empty? ] [ 2drop ] }
[ drop linear-case-quot ]
} cond ;
-! recursive-hashcode
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline
] [
[
[ [ , f ] compose [ , drop t ] recover ] curry all?
- ] { } make peek swap [ rethrow ] when
+ ] { } make last swap [ rethrow ] when
] if ; inline
TUPLE: condition error restarts continuation ;
HELP: with-destructors
{ $values { "quot" "a quotation" } }
-{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
+{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors using " { $link &dispose } " or " { $link |dispose } ". The former registers a destructor that will always run whether or not the quotation threw an error, and the latter registers a destructor that only runs if the quotation throws an error only. Destructors are run in reverse order from the order in which they were registered." }
{ $notes
"Destructors generalize " { $link with-disposal } ". The following two lines are equivalent, except that the second line establishes a new dynamic scope:"
{ $code
: dispose-each ( seq -- )
[
[ [ dispose ] curry [ , ] recover ] each
- ] { } make [ peek rethrow ] unless-empty ;
+ ] { } make [ last rethrow ] unless-empty ;
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
<PRIVATE
-: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
+: last/first ( seq -- pair ) [ last ] [ first ] bi 2array ;
: bootstrap-words ( classes -- classes' )
[ bootstrap-word ] map ;
USING: accessors arrays assocs classes classes.algebra
combinators definitions generic hashtables kernel
kernel.private layouts math namespaces quotations
-sequences words generic.single.private effects make ;
+sequences words generic.single.private effects make
+combinators.private ;
IN: generic.single
ERROR: no-method object generic ;
quote-methods
prune-redundant-predicates
class-predicates
- [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
+ [ last ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
M: predicate-engine compile-engine
[ compile-predicate-engine ] [ class>> ] bi
] [ append-nums ] if ;
: begin-utf16le ( stream byte -- stream char )
- over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
+ over stream-read1 dup [ double-le ] [ 2drop replacement-char ] if ;
M: utf16le decode-char
drop dup stream-read1 dup [ begin-utf16le ] when nip ;
: encode-first ( char -- byte1 byte2 )
-10 shift
- dup -8 shift BIN: 11011000 bitor
- swap HEX: FF bitand ;
+ [ -8 shift BIN: 11011000 bitor ] [ HEX: FF bitand ] bi ;
: encode-second ( char -- byte3 byte4 )
BIN: 1111111111 bitand
- dup -8 shift BIN: 11011100 bitor
- swap BIN: 11111111 bitand ;
+ [ -8 shift BIN: 11011100 bitor ] [ BIN: 11111111 bitand ] bi ;
-: stream-write2 ( stream char1 char2 -- )
- rot [ stream-write1 ] curry bi@ ;
+: stream-write2 ( char1 char2 stream -- )
+ [ stream-write1 ] curry bi@ ;
-: char>utf16be ( stream char -- )
- dup HEX: FFFF > [
- HEX: 10000 -
- 2dup encode-first stream-write2
- encode-second stream-write2
- ] [ h>b/b swap stream-write2 ] if ;
+: char>utf16be ( char stream -- )
+ over HEX: FFFF > [
+ [ HEX: 10000 - ] dip
+ [ [ encode-first ] dip stream-write2 ]
+ [ [ encode-second ] dip stream-write2 ] 2bi
+ ] [ [ h>b/b swap ] dip stream-write2 ] if ;
M: utf16be encode-char ( char stream encoding -- )
- drop swap char>utf16be ;
+ drop char>utf16be ;
-: char>utf16le ( char stream -- )
- dup HEX: FFFF > [
- HEX: 10000 -
- 2dup encode-first swap stream-write2
- encode-second swap stream-write2
- ] [ h>b/b stream-write2 ] if ;
+: char>utf16le ( stream char -- )
+ over HEX: FFFF > [
+ [ HEX: 10000 - ] dip
+ [ [ encode-first swap ] dip stream-write2 ]
+ [ [ encode-second swap ] dip stream-write2 ] 2bi
+ ] [ [ h>b/b ] dip stream-write2 ] if ;
M: utf16le encode-char ( char stream encoding -- )
- drop swap char>utf16le ;
+ drop char>utf16le ;
! UTF-16
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Outputs the smallest of two real numbers." } ;
+HELP: clamp
+{ $values { "x" real } { "min" real } { "max" real } { "y" real } }
+{ $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or outputs one of the endpoints." } ;
+
HELP: between?
{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
{ $subsection "order-specifiers" }
"Utilities for comparing objects:"
{ $subsection after? }
+{ $subsection after? }
{ $subsection before? }
{ $subsection after=? }
{ $subsection before=? }
[ +eq+ ] [ 4 4 <=> ] unit-test
[ +gt+ ] [ 4 3 <=> ] unit-test
+[ 20 ] [ 20 0 100 clamp ] unit-test
+[ 0 ] [ -20 0 100 clamp ] unit-test
+[ 100 ] [ 120 0 100 clamp ] unit-test
: min ( x y -- z ) [ before? ] most ; inline
: max ( x y -- z ) [ after? ] most ; inline
+: clamp ( x min max -- y ) [ max ] dip min ; inline
: between? ( x y z -- ? )
pick after=? [ after=? ] [ 2drop f ] if ; inline
PRIVATE>
-: namespace ( -- namespace ) namestack* peek ; inline
+: namespace ( -- namespace ) namestack* last ; inline
: namestack ( -- namestack ) namestack* clone ;
: set-namestack ( namestack -- ) >vector 0 setenv ;
: global ( -- g ) 21 getenv { hashtable } declare ; inline
{ join concat concat-as } related-words
-HELP: peek
+HELP: last
{ $values { "seq" sequence } { "elt" object } }
{ $description "Outputs the last element of a sequence." }
{ $errors "Throws an error if the sequence is empty." } ;
-{ peek pop pop* } related-words
+{ pop pop* } related-words
HELP: pop*
{ $values { "seq" "a resizable mutable sequence" } }
{ $subsection second }
{ $subsection third }
{ $subsection fourth }
+"Extracting the last element:"
+{ $subsection last }
"Unpacking sequences:"
{ $subsection first2 }
{ $subsection first3 }
{ $subsection first4 }
-{ $see-also nth peek } ;
+{ $see-also nth } ;
ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:"
ARTICLE: "sequences-stacks" "Treating sequences as stacks"
"The classical stack operations, modifying a sequence in place:"
-{ $subsection peek }
{ $subsection push }
{ $subsection pop }
{ $subsection pop* }
[ 0 swap copy ] keep
] new-like ;
-: peek ( seq -- elt ) [ length 1 - ] [ nth ] bi ;
+: last ( seq -- elt ) [ length 1 - ] [ nth ] bi ;
: pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ;
[ rest ] [ first-unsafe ] bi ;
: unclip-last ( seq -- butlast last )
- [ but-last ] [ peek ] bi ;
+ [ but-last ] [ last ] bi ;
: unclip-slice ( seq -- rest-slice first )
[ rest-slice ] [ first-unsafe ] bi ; inline
[ find-last ] (map-find) ; inline
: unclip-last-slice ( seq -- butlast-slice last )
- [ but-last-slice ] [ peek ] bi ; inline
+ [ but-last-slice ] [ last ] bi ; inline
: <flat-slice> ( seq -- slice )
dup slice? [ { } like ] when
[ <reversed> ] bi@ split1-slice [ <reversed> ] bi@
[ f ] [ swap ] if-empty ;
+<PRIVATE
+
: (split) ( separators n seq -- )
3dup rot [ member? ] curry find-from drop
[ [ swap subseq , ] 2keep 1 + swap (split) ]
: split, ( seq separators -- ) 0 rot (split) ;
+PRIVATE>
+
: split ( seq separators -- pieces )
[ split, ] { } make ;
but-last-slice [
"\r" ?tail drop "\r" split
] map
- ] keep peek "\r" split suffix concat
+ ] keep last "\r" split suffix concat
] [
1array
] if ;
[ ] [ V{ 1 5 } "funny-stack" get push ] unit-test
[ ] [ V{ 2 3 } "funny-stack" get push ] unit-test
[ V{ 2 3 } ] [ "funny-stack" get pop ] unit-test
-[ V{ 1 5 } ] [ "funny-stack" get peek ] unit-test
+[ V{ 1 5 } ] [ "funny-stack" get last ] unit-test
[ V{ 1 5 } ] [ "funny-stack" get pop ] unit-test
[ "funny-stack" get pop ] must-fail
[ "funny-stack" get pop ] must-fail
[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test
-[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test
\ No newline at end of file
+[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test
: vocab-dir+ ( vocab str/f -- path )
[ vocab-name "." split ] dip
- [ [ dup peek ] dip append suffix ] when*
+ [ [ dup last ] dip append suffix ] when*
"/" join ;
: find-vocab-root ( vocab -- path/f )
: qualified-search ( name manifest -- word/f )
qualified-vocabs>>
- (vocab-search) 0 = [ drop f ] [ peek ] if ;
+ (vocab-search) 0 = [ drop f ] [ last ] if ;
PRIVATE>
if ;
DEFER: check-status
: quit-game ( vector -- ) drop "you're a quitter" print ;
-: quit? ( vector -- t/f ) peek "quit" = ;
+: quit? ( vector -- t/f ) last "quit" = ;
: end-game ( vector -- )
dup victory?
[ drop "You WON!" ]
: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
\r
: dimension ( array -- x ) length 1- ; inline \r
-: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline\r
: change-last ( seq quot -- ) \r
[ [ dimension ] keep ] dip change-nth ; inline\r
\r
: set-end ( duration -- end-time ) duration>milliseconds millis + ;
: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; inline
: animate ( quot duration -- ) reset-progress set-end loop ; inline
-: sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline
\ No newline at end of file
+: sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline
--- /dev/null
+! Copyright (c) 2009 Samuel Tardieu.
+! See See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: backtrack
+
+HELP: fail
+{ $description "Signal that the current alternative is not acceptable. This will cause either backtracking to occur, or a failure to be signalled, as explained in the " { $link amb } " word description." }
+{ $see-also amb cut-amb }
+;
+
+HELP: amb
+{ $values
+ { "seq" "the alternatives" }
+ { "elt" "one of the alternatives" }
+}
+{ $description "The amb (ambiguous) word saves the state of the current computation (through the " { $vocab-link "continuations" } " vocabulary) and returns the first alternative. When " { $link fail } " is invoked, the saved state will be restored and the next alternative will be returned. When there are no more alternatives, " { $link fail } " will go up one level to the location of the previous " { $link amb } " call. If there are no more calls up the chain, an error will be signalled." }
+{ $see-also fail cut-amb }
+;
+
+HELP: cut-amb
+{ $description "Reset the amb system. Calling this word resets the whole stack of " { $link amb } " calls and should not be done lightly."}
+{ $see-also amb fail }
+;
+
+HELP: amb-execute
+{ $values
+ { "seq" "a list of words" }
+}
+{ $description "Execute the first word in the list, and go to the next one if " { $link fail } " is called." } ;
+
+HELP: if-amb
+{ $values
+ { "true" "a quotation with stack effect ( -- ? )" }
+ { "false" "a quotation" }
+ { "?" "a boolean" }
+}
+{ $description "Execute the first quotation and returns " { $link t } " if it returns " { $link t } " itself. If it fails with " { $link fail } " or returns " { $link f } ", then the second quotation is executed and " { $link f } " is returned." } ;
+
+HELP: amb-all
+{ $values
+ { "quot" "a quotation with stack effect ( -- )" }
+}
+{ $description "Execute all the alternatives in the quotation by calling " { $link fail } " repeatedly at the end." }
+{ $see-also bag-of fail }
+;
+
+HELP: bag-of
+{ $values
+ { "quot" "a quotation with stack effect ( -- result )" }
+ { "seq" "a sequence" }
+}
+{ $description "Execute all the alternatives in the quotation and collect the results." }
+{ $see-also amb-all } ;
\ No newline at end of file
--- /dev/null
+! Copyright (c) 2009 Samuel Tardieu.
+! See See http://factorcode.org/license.txt for BSD license.
+USING: backtrack math tools.test ;
+
+cut-amb
+[ 1 ] [ { 1 2 } amb ] unit-test
+[ V{ { 1 2 } } ] [ [ { 1 2 } ] bag-of ] unit-test
+[ V{ 1 2 } ] [ [ { 1 2 } amb ] bag-of ] unit-test
+[ cut-amb { } amb ] must-fail
+[ fail ] must-fail
+[ V{ 1 10 2 20 } ] [ [ { 1 2 } amb { 1 10 } amb * ] bag-of ] unit-test
+[ V{ 7 -1 } ] [ [ 3 4 { + - } amb-execute ] bag-of ] unit-test
+[ "foo" t ] [ [ "foo" t ] [ "bar" ] if-amb ] unit-test
+[ "bar" f ] [ [ "foo" f ] [ "bar" ] if-amb ] unit-test
+[ "bar" f ] [ [ "foo" fail ] [ "bar" ] if-amb ] unit-test
\r
<PRIVATE\r
\r
+: preserve ( quot var -- ) [ get [ call ] dip ] keep set ; inline\r
+\r
+: amb-preserve ( quot -- ) failure preserve ; inline\r
+\r
: unsafe-number-from-to ( to from -- to from+n )\r
2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;\r
\r
[ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi\r
'[ _ 0 unsafe-number-from-to nip _ case ] ;\r
\r
-: if-amb ( true false -- )\r
+: if-amb ( true false -- ? )\r
[\r
[ { t f } amb ]\r
[ '[ @ require t ] ]\r
[ '[ @ f ] ]\r
tri* if\r
- ] with-scope ; inline\r
+ ] amb-preserve ; inline\r
\r
: cut-amb ( -- )\r
f failure set ;\r
+\r
+: amb-all ( quot -- )\r
+ [ { t f } amb [ call fail ] [ drop ] if ] amb-preserve ; inline\r
+\r
+: bag-of ( quot -- seq )\r
+ V{ } clone [ '[ @ _ push ] amb-all ] keep ; inline\r
get-state element>> pop ; inline
: peek-scope ( -- ht )
- get-state scope>> peek ; inline
+ get-state scope>> last ; inline
: read-elements ( -- )
read-element-type
read-int32 drop
get-state
[scope-changer] change-scope
- scope>> peek ; inline
+ scope>> last ; inline
M: bson-object element-data-read ( type -- object )
(object-data-read) ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cursors math tools.test make ;
+IN: cursors.tests
+
+[ 2 t ] [ { 2 3 } [ even? ] find ] unit-test
+[ 3 t ] [ { 2 3 } [ odd? ] find ] unit-test
+[ f f ] [ { 2 4 } [ odd? ] find ] unit-test
+
+[ { 2 3 } ] [ { 1 2 } [ 1 + ] map ] unit-test
+[ { 2 3 } ] [ { 1 2 } [ [ 1 + , ] each ] { 2 3 } make ] unit-test
+
+[ t ] [ { } [ odd? ] all? ] unit-test
+[ t ] [ { 1 3 5 } [ odd? ] all? ] unit-test
+[ f ] [ { 1 3 5 6 } [ odd? ] all? ] unit-test
+
+[ t ] [ { } [ odd? ] all? ] unit-test
+[ t ] [ { 1 3 5 } [ odd? ] any? ] unit-test
+[ f ] [ { 2 4 6 } [ odd? ] any? ] unit-test
+
+[ { 1 3 5 } ] [ { 1 2 3 4 5 6 } [ odd? ] filter ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math sequences sequences.private ;
+IN: cursors
+
+GENERIC: cursor-done? ( cursor -- ? )
+GENERIC: cursor-get-unsafe ( cursor -- obj )
+GENERIC: cursor-advance ( cursor -- )
+GENERIC: cursor-valid? ( cursor -- ? )
+GENERIC: cursor-write ( obj cursor -- )
+
+ERROR: cursor-ended cursor ;
+
+: cursor-get ( cursor -- obj )
+ dup cursor-done?
+ [ cursor-ended ] [ cursor-get-unsafe ] if ; inline
+
+: find-done? ( quot cursor -- ? )
+ dup cursor-done? [ 2drop t ] [ cursor-get-unsafe swap call ] if ; inline
+
+: cursor-until ( quot cursor -- )
+ [ find-done? not ]
+ [ cursor-advance drop ] bi-curry bi-curry while ; inline
+
+: cursor-each ( cursor quot -- )
+ [ f ] compose swap cursor-until ; inline
+
+: cursor-find ( cursor quot -- obj ? )
+ swap [ cursor-until ] keep
+ dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
+
+: cursor-any? ( cursor quot -- ? )
+ cursor-find nip ; inline
+
+: cursor-all? ( cursor quot -- ? )
+ [ not ] compose cursor-any? not ; inline
+
+: cursor-map-quot ( quot to -- quot' )
+ [ [ call ] dip cursor-write ] 2curry ; inline
+
+: cursor-map ( from to quot -- )
+ swap cursor-map-quot cursor-each ; inline
+
+: cursor-write-if ( obj quot to -- )
+ [ over [ call ] dip ] dip
+ [ cursor-write ] 2curry when ; inline
+
+: cursor-filter-quot ( quot to -- quot' )
+ [ cursor-write-if ] 2curry ; inline
+
+: cursor-filter ( from to quot -- )
+ swap cursor-filter-quot cursor-each ; inline
+
+TUPLE: from-sequence { seq sequence } { n integer } ;
+
+: >from-sequence< ( from-sequence -- n seq )
+ [ n>> ] [ seq>> ] bi ; inline
+
+M: from-sequence cursor-done? ( cursor -- ? )
+ >from-sequence< length >= ;
+
+M: from-sequence cursor-valid?
+ >from-sequence< bounds-check? not ;
+
+M: from-sequence cursor-get-unsafe
+ >from-sequence< nth-unsafe ;
+
+M: from-sequence cursor-advance
+ [ 1+ ] change-n drop ;
+
+: >input ( seq -- cursor )
+ 0 from-sequence boa ; inline
+
+: iterate ( seq quot iterator -- )
+ [ >input ] 2dip call ; inline
+
+: each ( seq quot -- ) [ cursor-each ] iterate ; inline
+: find ( seq quot -- ? ) [ cursor-find ] iterate ; inline
+: any? ( seq quot -- ? ) [ cursor-any? ] iterate ; inline
+: all? ( seq quot -- ? ) [ cursor-all? ] iterate ; inline
+
+TUPLE: to-sequence { seq sequence } { exemplar sequence } ;
+
+M: to-sequence cursor-write
+ seq>> push ;
+
+: freeze ( cursor -- seq )
+ [ seq>> ] [ exemplar>> ] bi like ; inline
+
+: >output ( seq -- cursor )
+ [ [ length ] keep new-resizable ] keep
+ to-sequence boa ; inline
+
+: transform ( seq quot transformer -- newseq )
+ [ [ >input ] [ >output ] bi ] 2dip
+ [ call ] [ 2drop freeze ] 3bi ; inline
+
+: map ( seq quot -- ) [ cursor-map ] transform ; inline
+: filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline
: make-descriptive ( word -- )
dup [ ] [ def>> ] [ stack-effect ] tri [descriptive]
- '[ drop _ ] annotate-methods ;
+ '[ drop _ ] annotate ;
: define-descriptive ( word def effect -- )
[ drop "descriptive-definition" set-word-prop ]
: fully-qualified ( name -- name )
{
{ [ dup empty? ] [ "." append ] }
- { [ dup peek CHAR: . = ] [ ] }
+ { [ dup last CHAR: . = ] [ ] }
{ [ t ] [ "." append ] }
}
cond ;
[ [ print-error-and-restarts ] error-hook set listener ] with-scope ;
: server ( port -- server )
- <threaded-server>
+ utf8 <threaded-server>
"tty-server" >>name
- utf8 >>encoding
swap local-server >>insecure
[ start-listener ] >>handler
f >>timeout ;
dup dup >vocab-link where normalize-loc 4array ;
: sort-xrefs ( seq -- seq' )
- [ [ first ] dip first <=> ] sort ; inline
+ [ [ first ] dip first <=> ] sort ;
: format-xrefs ( seq -- seq' )
- [ word? ] filter [ word>xref ] map ; inline
+ [ word? ] filter [ word>xref ] map ;
: filter-prefix ( seq prefix -- seq )
- [ drop-prefix nip length 0 = ] curry filter prune ; inline
+ [ drop-prefix nip length 0 = ] curry filter prune ;
MEMO: (vocab-words) ( name -- seq )
>vocab-link words [ name>> ] map ;
: current-words ( -- seq )
manifest get
[ search-vocabs>> ] [ qualified-vocabs>> ] bi [ words>> ] bi@
- assoc-union keys ; inline
+ assoc-union keys ;
: vocabs-words ( names -- seq )
- prune [ (vocab-words) ] map concat ; inline
+ prune [ (vocab-words) ] map concat ;
PRIVATE>
: closing-tag? ( string -- ? )
[ f ]
- [ { [ first CHAR: / = ] [ peek CHAR: / = ] } 1|| ] if-empty ;
+ [ { [ first CHAR: / = ] [ last CHAR: / = ] } 1|| ] if-empty ;
: <tag> ( name attributes closing? -- tag )
tag new
--- /dev/null
+Kobi Lurie
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Kobi Lurie, Doug Coleman.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors fry images.loader images.normalization\r
+images.processing.rotation kernel literals math sequences\r
+tools.test images.processing.rotation.private ;\r
+IN: images.processing.rotation.tests\r
+\r
+: first-row ( seq^2 -- seq ) first ;\r
+: first-col ( seq^2 -- item ) harvest [ first ] map ;\r
+: last-row ( seq^2 -- item ) last ;\r
+: last-col ( seq^2 -- item ) harvest [ last ] map ;\r
+: end-of-first-row ( seq^2 -- item ) first-row last ;\r
+: first-of-first-row ( seq^2 -- item ) first-row first ;\r
+: end-of-last-row ( seq^2 -- item ) last-row last ;\r
+: first-of-last-row ( seq^2 -- item ) last-row first ;\r
+\r
+<<\r
+\r
+: clone-image ( image -- new-image )\r
+ clone [ clone ] change-bitmap ;\r
+\r
+>>\r
+\r
+CONSTANT: pasted-image\r
+ $[\r
+ "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"\r
+ load-image normalize-image clone-image\r
+ ]\r
+\r
+CONSTANT: pasted-image90\r
+ $[\r
+ "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"\r
+ load-image normalize-image clone-image\r
+ ]\r
+\r
+CONSTANT: lake-image\r
+ $[\r
+ "vocab:images/processing/rotation/test-bitmaps/lake.bmp"\r
+ load-image preprocess\r
+ ]\r
+\r
+[ t ] [ pasted-image dup clone-image 4 [ 90 rotate ] times = ] unit-test\r
+[ t ] [ pasted-image dup clone-image 2 [ 180 rotate ] times = ] unit-test\r
+[ t ] [ pasted-image dup clone-image 270 rotate 90 rotate = ] unit-test\r
+[ t ] [\r
+ pasted-image dup clone-image dup { 90 180 90 } [ rotate drop ] with each =\r
+] unit-test\r
+\r
+[ t ] [\r
+ pasted-image 90 rotate\r
+ pasted-image90 = \r
+] unit-test\r
+\r
+[ t ] [\r
+ "vocab:images/processing/rotation/test-bitmaps/small.bmp"\r
+ load-image 90 rotate \r
+ "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"\r
+ load-image normalize-image =\r
+] unit-test\r
+ \r
+[ t ] [\r
+ lake-image\r
+ [ first-of-first-row ]\r
+ [ 90 (rotate) end-of-first-row ] bi =\r
+] unit-test\r
+\r
+[ t ]\r
+[ lake-image [ first-row ] [ 90 (rotate) last-col ] bi = ] unit-test\r
+\r
+[ t ]\r
+[ lake-image [ last-col ] [ 90 (rotate) last-row reverse ] bi = ] unit-test\r
+\r
+[ t ]\r
+[ lake-image [ last-row ] [ 90 (rotate) first-col ] bi = ] unit-test\r
+\r
+[ t ]\r
+[ lake-image [ first-col ] [ 90 (rotate) first-row reverse ] bi = ] unit-test\r
--- /dev/null
+! Copyright (C) 2009 Kobi Lurie.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays colors combinators
+combinators.short-circuit fry grouping images images.bitmap
+images.loader images.normalization kernel locals math sequences ;
+IN: images.processing.rotation
+
+ERROR: unsupported-rotation degrees ;
+
+<PRIVATE
+
+: rotate-90 ( seq^3 -- seq^3 ) flip [ reverse ] map ;
+: rotate-180 ( seq^3 -- seq^3 ) reverse [ reverse ] map ;
+: rotate-270 ( seq^3 -- seq^3 ) flip reverse ;
+
+: (rotate) ( seq n -- seq' )
+ {
+ { 0 [ ] }
+ { 90 [ rotate-90 ] }
+ { 180 [ rotate-180 ] }
+ { 270 [ rotate-270 ] }
+ [ unsupported-rotation ]
+ } case ;
+
+: rows-remove-pad ( byte-rows -- pixels' )
+ [ dup length 4 mod head* ] map ;
+
+: row-length ( image -- n )
+ [ bitmap>> length ] [ dim>> second ] bi /i ;
+
+: image>byte-rows ( image -- byte-rows )
+ [ bitmap>> ] [ row-length ] bi group rows-remove-pad ;
+
+: (seperate-to-pixels) ( byte-rows image -- pixel-rows )
+ component-order>> bytes-per-pixel '[ _ group ] map ;
+
+: image>pixel-rows ( image -- pixel-rows )
+ [ image>byte-rows ] keep (seperate-to-pixels) ;
+
+: flatten-table ( seq^3 -- seq )
+ [ concat ] map concat ;
+
+: preprocess ( image -- pixelrows )
+ normalize-image image>pixel-rows ;
+
+: ?reverse-dimensions ( image n -- )
+ { 270 90 } member? [ [ reverse ] change-dim ] when drop ;
+
+: normalize-degree ( n -- n' ) 360 rem ;
+
+: processing-effect ( image quot -- image' )
+ '[ preprocess @ flatten-table ] [ (>>bitmap) ] [ ] tri ; inline
+
+:: rotate' ( image n -- image )
+ n normalize-degree :> n'
+ image preprocess :> pixel-table
+ image n' ?reverse-dimensions
+ pixel-table n' (rotate) :> table-rotated
+ image table-rotated flatten-table >>bitmap ;
+
+PRIVATE>
+
+: rotate ( image n -- image' )
+ normalize-degree
+ [ '[ _ (rotate) ] processing-effect ] [ ?reverse-dimensions ] 2bi ;
+
+: reflect-y-axis ( image -- image )
+ [ [ reverse ] map ] processing-effect ;
+
+: reflect-x-axis ( image -- image )
+ [ reverse ] processing-effect ;
PREDICATE: channel-mode < mode name>> first "#&" member? ;
PREDICATE: participant-mode < channel-mode parameter>> ;
PREDICATE: ctcp < privmsg
- trailing>> { [ length 1 > ] [ first 1 = ] [ peek 1 = ] } 1&& ;
+ trailing>> { [ length 1 > ] [ first 1 = ] [ last 1 = ] } 1&& ;
PREDICATE: action < ctcp trailing>> rest "ACTION" head? ;
M: rpl-names post-process-irc-message ( rpl-names -- )
max-speed [0,b] ;
: change-player-speed ( inc player -- )
- [ + speed-range clamp-to-range ] change-speed drop ;
+ [ + 0 max-speed clamp ] change-speed drop ;
: multiply-player-speed ( n player -- )
- [ * speed-range clamp-to-range ] change-speed drop ;
+ [ * 0 max-speed clamp ] change-speed drop ;
: distance-to-move ( seconds-passed player -- distance )
speed>> * ;
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors combinators kernel literals locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ;
+USING: accessors arrays colors combinators fry jamshred.oint
+kernel literals locals math math.constants math.matrices
+math.order math.quadratic math.ranges math.vectors random
+sequences specialized-arrays.float vectors ;
FROM: jamshred.oint => distance ;
IN: jamshred.tunnel
: segment-number++ ( segment -- )
[ number>> 1+ ] keep (>>number) ;
+: clamp-length ( n seq -- n' )
+ 0 swap length clamp ;
+
: random-color ( -- color )
{ 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
: (random-segments) ( segments n -- segments )
dup 0 > [
- [ dup peek 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
: sub-tunnel ( from to segments -- segments )
#! return segments between from and to, after clamping from and to to
#! valid values
- [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
+ [ '[ _ clamp-length ] bi@ ] keep <slice> ;
: nearer-segment ( segment segment oint -- segment )
#! return whichever of the two segments is nearer to the oint
] dip nearer-segment ;
: get-segment ( segments n -- segment )
- over sequence-index-range clamp-to-range swap nth ;
+ over clamp-length swap nth ;
: next-segment ( segments current-segment -- segment )
number>> 1+ get-segment ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators combinators.smart
+destructors fry io io.encodings.utf8 kernel managed-server
+namespaces parser sequences sorting splitting strings.parser
+unicode.case unicode.categories calendar calendar.format
+locals multiline io.encodings.binary io.encodings.string
+prettyprint ;
+IN: managed-server.chat
+
+TUPLE: chat-server < managed-server ;
+
+SYMBOL: commands
+commands [ H{ } clone ] initialize
+
+SYMBOL: chat-docs
+chat-docs [ H{ } clone ] initialize
+
+CONSTANT: line-beginning "-!- "
+
+: handle-me ( string -- )
+ [
+ [ "* " username " " ] dip
+ ] "" append-outputs-as send-everyone ;
+
+: handle-quit ( string -- )
+ client [ (>>object) ] [ t >>quit? drop ] bi ;
+
+: handle-help ( string -- )
+ [
+ "Commands: "
+ commands get keys natural-sort ", " join append print flush
+ ] [
+ chat-docs get ?at
+ [ print flush ]
+ [ "Unknown command: " prepend print flush ] if
+ ] if-empty ;
+
+: usage ( string -- )
+ chat-docs get at print flush ;
+
+: username-taken-string ( username -- string )
+ "The username ``" "'' is already in use; try again." surround ;
+
+: warn-name-changed ( old new -- )
+ [
+ [ line-beginning "``" ] 2dip
+ [ "'' is now known as ``" ] dip "''"
+ ] "" append-outputs-as send-everyone ;
+
+: handle-nick ( string -- )
+ [
+ "nick" usage
+ ] [
+ dup clients key? [
+ username-taken-string print flush
+ ] [
+ [ username swap warn-name-changed ]
+ [ username clients rename-at ]
+ [ client (>>username) ] tri
+ ] if
+ ] if-empty ;
+
+:: add-command ( quot docs key -- )
+ quot key commands get set-at
+ docs key chat-docs get set-at ;
+
+[ handle-help ]
+<" Syntax: /help [command]
+Displays the documentation for a command.">
+"help" add-command
+
+[ drop clients keys [ "``" "''" surround ] map ", " join print flush ]
+<" Syntax: /who
+Shows the list of connected users.">
+"who" add-command
+
+[ drop gmt timestamp>rfc822 print flush ]
+<" Syntax: /time
+Returns the current GMT time."> "time" add-command
+
+[ handle-nick ]
+<" Syntax: /nick nickname
+Changes your nickname.">
+"nick" add-command
+
+[ handle-me ]
+<" Syntax: /me action">
+"me" add-command
+
+[ handle-quit ]
+<" Syntax: /quit [message]
+Disconnects a user from the chat server."> "quit" add-command
+
+: handle-command ( string -- )
+ dup " " split1 swap >lower commands get at* [
+ call( string -- ) drop
+ ] [
+ 2drop "Unknown command: " prepend print flush
+ ] if ;
+
+: <chat-server> ( port -- managed-server )
+ "chat-server" utf8 chat-server new-managed-server ;
+
+: handle-chat ( string -- )
+ [
+ [ username ": " ] dip
+ ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-login
+ "Username: " write flush
+ readln ;
+
+M: chat-server handle-client-join
+ [
+ line-beginning username " has joined"
+ ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-client-disconnect
+ [
+ line-beginning username " has quit "
+ client object>> dup [ "\"" dup surround ] when
+ ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-already-logged-in
+ username username-taken-string print flush ;
+
+M: chat-server handle-managed-client*
+ readln dup f = [ t client (>>quit?) ] when
+ [
+ "/" ?head [ handle-command ] [ handle-chat ] if
+ ] unless-empty ;
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar continuations destructors io
+io.encodings.binary io.servers.connection io.sockets
+io.streams.duplex fry kernel locals math math.ranges multiline
+namespaces prettyprint random sequences sets splitting threads
+tools.continuations ;
+IN: managed-server
+
+TUPLE: managed-server < threaded-server clients ;
+
+TUPLE: managed-client
+input-stream output-stream local-address remote-address
+username object quit? ;
+
+HOOK: handle-login threaded-server ( -- username )
+HOOK: handle-managed-client* managed-server ( -- )
+HOOK: handle-already-logged-in managed-server ( -- )
+HOOK: handle-client-join managed-server ( -- )
+HOOK: handle-client-disconnect managed-server ( -- )
+
+ERROR: already-logged-in username ;
+
+M: managed-server handle-already-logged-in already-logged-in ;
+M: managed-server handle-client-join ;
+M: managed-server handle-client-disconnect ;
+
+: server ( -- managed-client ) managed-server get ;
+: client ( -- managed-client ) managed-client get ;
+: clients ( -- assoc ) server clients>> ;
+: client-streams ( -- assoc ) clients values ;
+: username ( -- string ) client username>> ;
+: everyone-else ( -- assoc )
+ clients [ drop username = not ] assoc-filter ;
+: everyone-else-streams ( -- assoc ) everyone-else values ;
+
+ERROR: no-such-client username ;
+
+<PRIVATE
+
+: (send-client) ( managed-client seq -- )
+ [ output-stream>> ] dip '[ _ print flush ] with-output-stream* ;
+
+PRIVATE>
+
+: send-client ( seq username -- )
+ clients ?at [ no-such-client ] [ (send-client) ] if ;
+
+: send-everyone ( seq -- )
+ [ client-streams ] dip '[ _ (send-client) ] each ;
+
+: send-everyone-else ( seq -- )
+ [ everyone-else-streams ] dip '[ _ (send-client) ] each ;
+
+<PRIVATE
+
+: <managed-client> ( username -- managed-client )
+ managed-client new
+ swap >>username
+ input-stream get >>input-stream
+ output-stream get >>output-stream
+ local-address get >>local-address
+ remote-address get >>remote-address ;
+
+: check-logged-in ( username -- username )
+ dup clients key? [ handle-already-logged-in ] when ;
+
+: add-managed-client ( -- )
+ client username check-logged-in clients set-at ;
+
+: delete-managed-client ( -- )
+ username server clients>> delete-at ;
+
+: handle-managed-client ( -- )
+ handle-login <managed-client> managed-client set
+ add-managed-client handle-client-join
+ [ handle-managed-client* client quit?>> not ] loop ;
+
+PRIVATE>
+
+M: managed-server handle-client*
+ managed-server set
+ [ handle-managed-client ]
+ [ delete-managed-client handle-client-disconnect ]
+ [ ] cleanup ;
+
+: new-managed-server ( port name encoding class -- server )
+ new-threaded-server
+ swap >>name
+ swap >>insecure
+ f >>timeout
+ H{ } clone >>clients ; inline
SYMBOLS: host-name target-os target-cpu message message-arg ;
: parse-args ( command-line -- )
- dup peek message-arg set
+ dup last message-arg set
[
{
[ host-name set ]
HELP: negmin
{ $values { "a" number } { "b" number } { "x" number } }
{ $description "Returns the most-negative value, or zero if both are positive." } ;
-
-HELP: clamp
-{ $values { "a" number } { "value" number } { "b" number } { "x" number } }
-{ $description "Returns the value when between " { $snippet "a" } " and " { $snippet "b" } ", " { $snippet "a" } " if <= " { $snippet "a" } ", or " { $snippet "b" } " if >= " { $snippet "b" } "." } ;
-
[ 0 ] [ 1 3 negmin ] unit-test
[ -3 ] [ 1 -3 negmin ] unit-test
[ -1 ] [ -1 3 negmin ] unit-test
-
-[ 0 ] [ 0 -1 2 clamp ] unit-test
-[ 1 ] [ 0 1 2 clamp ] unit-test
-[ 2 ] [ 0 3 2 clamp ] unit-test
-
: negmin ( a b -- x )
0 min min ;
-
-: clamp ( a value b -- x )
- min max ;
: (homogeneous-xyz) ( h -- xyz )
1 head* ; inline
: (homogeneous-w) ( h -- w )
- peek ; inline
+ last ; inline
: h+ ( a b -- c )
2dup [ (homogeneous-w) ] bi@ over =
: start-mmm-server ( -- )
output-stream get mmm-dump-output set
- <threaded-server> [ mmm-t-srv set ] keep
+ binary <threaded-server> [ mmm-t-srv set ] keep
"127.0.0.1" mmm-port get <inet4> >>insecure
- binary >>encoding
[ handle-mmm-connection ] >>handler
start-server* ;
check-options
start-mmm-server ;
-MAIN: run-mmm
\ No newline at end of file
+MAIN: run-mmm
! unit circle as NURBS
3 {
{ 1.0 0.0 1.0 }
- { $ √2/2 $ √2/2 $ √2/2 }
+ ${ √2/2 √2/2 √2/2 }
{ 0.0 1.0 1.0 }
- { $ -√2/2 $ √2/2 $ √2/2 }
+ ${ -√2/2 √2/2 √2/2 }
{ -1.0 0.0 1.0 }
- { $ -√2/2 $ -√2/2 $ √2/2 }
+ ${ -√2/2 -√2/2 √2/2 }
{ 0.0 -1.0 1.0 }
- { $ √2/2 $ -√2/2 $ √2/2 }
+ ${ √2/2 -√2/2 √2/2 }
{ 1.0 0.0 1.0 }
} { 0.0 0.0 0.0 0.25 0.25 0.5 0.5 0.75 0.75 1.0 1.0 1.0 } <nurbs-curve> test-nurbs set
[ t ] [ test-nurbs get 0.5 eval-nurbs { -1.0 0.0 } 0.00001 v~ ] unit-test
[ t ] [ test-nurbs get 0.75 eval-nurbs { 0.0 -1.0 } 0.00001 v~ ] unit-test
-[ t ] [ test-nurbs get 0.125 eval-nurbs { $ √2/2 $ √2/2 } 0.00001 v~ ] unit-test
-[ t ] [ test-nurbs get 0.375 eval-nurbs { $ -√2/2 $ √2/2 } 0.00001 v~ ] unit-test
-[ t ] [ test-nurbs get 0.625 eval-nurbs { $ -√2/2 $ -√2/2 } 0.00001 v~ ] unit-test
-[ t ] [ test-nurbs get 0.875 eval-nurbs { $ √2/2 $ -√2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.125 eval-nurbs ${ √2/2 √2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.375 eval-nurbs ${ -√2/2 √2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.625 eval-nurbs ${ -√2/2 -√2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.875 eval-nurbs ${ √2/2 -√2/2 } 0.00001 v~ ] unit-test
: (find-unusual-terms) ( n seq -- seq/f )
[ [ arithmetic-terms ] with map ] keep
- '[ _ [ peek ] dip member? ] find nip ;
+ '[ _ [ last ] dip member? ] find nip ;
: find-unusual-terms ( seq -- seq/? )
unclip-slice over (find-unusual-terms) [
] { } make nip ; inline
: most-frequent ( seq -- elt )
- frequency-analysis sort-values keys peek ;
+ frequency-analysis sort-values keys last ;
: crack-key ( seq key-length -- key )
[ " " decrypt ] dip group but-last-slice
[ length swap - 1- ] keep ?nth 0 or ;
: next ( colortile seq -- )
- [ nth* ] [ peek + ] [ push ] tri ;
+ [ nth* ] [ last + ] [ push ] tri ;
: ways ( length colortile -- permutations )
- V{ 1 } clone [ [ next ] 2curry times ] keep peek 1- ;
+ V{ 1 } clone [ [ next ] 2curry times ] keep last 1- ;
: (euler116) ( length -- permutations )
3 [1,b] [ ways ] with sigma ;
[ 4 short tail* sum ] keep push ;
: (euler117) ( n -- m )
- V{ 1 } clone tuck [ next ] curry times peek ;
+ V{ 1 } clone tuck [ next ] curry times last ;
PRIVATE>
<PRIVATE
: next-keys ( key -- keys )
- [ peek ] [ 10 swap sum - ] bi [ 2array ] with map ;
+ [ last ] [ 10 swap sum - ] bi [ 2array ] with map ;
: next-table ( assoc -- assoc )
H{ } clone swap
! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax multiline quotations sequences sequences.product ;
-IN: sequences
+USING: help.markup help.syntax multiline quotations sequences ;
+IN: sequences.product
HELP: product-sequence
{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
yaw>> 0.0
${ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
: clamp-pitch ( pitch -- pitch' )
- 90.0 min -90.0 max ;
+ -90.0 90.0 clamp ;
: walk-forward ( player -- )
dup forward-vector [ v+ ] curry change-velocity drop ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.servers.connection accessors threads
-calendar calendar.format ;
+USING: accessors calendar calendar.format io io.encodings.ascii
+io.servers.connection threads ;
IN: time-server
: handle-time-client ( -- )
now timestamp>rfc822 print ;
: <time-server> ( -- threaded-server )
- <threaded-server>
+ ascii <threaded-server>
"time-server" >>name
1234 >>insecure
[ handle-time-client ] >>handler ;
IN: tty-server
: <tty-server> ( port -- )
- <threaded-server>
+ utf8 <threaded-server>
"tty-server" >>name
- utf8 >>encoding
swap local-server >>insecure
[ listener ] >>handler
start-server ;
[
f <blog>
[ deposit-blog-slots ]
- [ "id" value >>id ]
- [ update-tuple ]
- tri
+ [ "id" value >>id update-tuple ] bi
<url>
"$planet/admin" >>path
syn keyword factorCompileDirective inline foldable parsing
syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry roll tri-curry* swap tri-curry@ 2nip and throw set-retainstack bi-curry (clone) hashcode* compose spin 2dip if 3tri unless compose? tuple keep 2curry equal? set-datastack assert tri 2drop most <wrapper> boolean? identity-tuple? null new set-callstack dip bi-curry@ rot -roll xor identity-tuple boolean
-syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map <enum> assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? at-default unzip
+syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map <enum> assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip
syn keyword factorKeyword case execute-effect dispatch-case-quot <buckets> no-cond no-case? 3cleave>quot contiguous-range? 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case hash-dispatch-quot case>quot 3cleave wrong-values alist>quot hash-case-table hash-case-quot case-find (distribute-buckets) cond cleave distribute-buckets call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot
syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex <fp-nan> < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float 1+ 1- fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f
syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter-here last-index-from prepare-index reversed index-from cut* pad-tail (indices) concat-as remq but-last snip trim-tail nths nth 2pusher sequence slice? <slice> partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length delq drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift delete sigma new-sequence follow like delete-nth first4 1sequence reverse slice unless-empty padding virtual@ repetition? index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head replicate set-fourth peek shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode memq? pop set-nth ?nth <flat-slice> second change-each join when-empty accumulator immutable-sequence? <reversed> all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? <repetition> trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim
io.encodings.binary io.servers.connection kernel
memoize namespaces parser sets sequences serialize
threads vocabs vocabs.parser words ;
-
IN: modules.rpc-server
SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
: do-rpc ( args word -- bytes )
- [ execute ] curry with-datastack object>bytes ; inline
+ [ execute ] curry with-datastack object>bytes ; inline
MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
-: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize
- swap at "executer" get execute( args word -- bytes ) write flush ;
-
-: (serve) ( -- ) deserialize dup serving-vocabs get-global index
- [ process ] [ drop ] if ;
-
-: start-serving-vocabs ( -- ) [
- <threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler
- start-server ] in-thread ;
-
-: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when
- current-vocab serving-vocabs get-global adjoin
- "get-words" create-in
- in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
- (( -- words )) define-inline ;
+: process ( vocabspec -- )
+ vocab-words [ deserialize ] dip deserialize
+ swap at "executer" get execute( args word -- bytes ) write flush ;
+
+: (serve) ( -- )
+ deserialize dup serving-vocabs get-global index
+ [ process ] [ drop ] if ;
+
+: start-serving-vocabs ( -- )
+ [
+ binary <threaded-server>
+ 5000 >>insecure
+ [ (serve) ] >>handler
+ start-server
+ ] in-thread ;
+
+: (service) ( -- )
+ serving-vocabs get-global empty? [ start-serving-vocabs ] when
+ current-vocab serving-vocabs get-global adjoin
+ "get-words" create-in
+ in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
+ (( -- words )) define-inline ;
SYNTAX: service \ do-rpc "executer" set (service) ;
SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
load-vocab-hook [
- [ dup words>> values
- \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ]
-append ] change-global
\ No newline at end of file
+ [
+ dup words>> values
+ \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each
+ ] append
+] change-global
mov %edx,%eax
ret
+DEF(long long,read_timestamp_counter,(void)):
+ rdtsc
+ ret
+
DEF(void,primitive_inline_cache_miss,(void)):
mov (%esp),%ebx
DEF(void,primitive_inline_cache_miss_tail,(void)):
#ifdef WINDOWS
.section .drectve
.ascii " -export:check_sse2"
+ .ascii " -export:read_timestamp_counter"
#endif
call *ARG3 /* call memcpy */
ret /* return _with new stack_ */
+DEF(long long,read_timestamp_counter,(void)):
+ mov $0,%rax
+ rdtsc
+ shl $32,%rdx
+ or %rdx,%rax
+ ret
+
DEF(void,primitive_inline_cache_miss,(void)):
mov (%rsp),%rbx
DEF(void,primitive_inline_cache_miss_tail,(void)):
projects / factor.git / commitdiff
