Merge branch 'master' of git://factorcode.org/git/factor into clean-linux-x86-32
Maxim Savchenko
commit
8b9d521b40
|
|
@ -6,9 +6,9 @@ IN: hash2.tests
|
|||
|
||||
: sample-hash ( -- hash )
|
||||
5 <hash2>
|
||||
dup 2 3 "foo" roll set-hash2
|
||||
dup 4 2 "bar" roll set-hash2
|
||||
dup 4 7 "other" roll set-hash2 ;
|
||||
[ [ 2 3 "foo" ] dip set-hash2 ] keep
|
||||
[ [ 4 2 "bar" ] dip set-hash2 ] keep
|
||||
[ [ 4 7 "other" ] dip set-hash2 ] keep ;
|
||||
|
||||
[ "foo" ] [ 2 3 sample-hash hash2 ] unit-test
|
||||
[ "bar" ] [ 4 2 sample-hash hash2 ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
USING: kernel sequences arrays math vectors ;
|
||||
! Copyright (C) 2007 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences arrays math vectors locals ;
|
||||
IN: hash2
|
||||
|
||||
! Little ad-hoc datastructure used to map two numbers
|
||||
|
|
@ -22,8 +24,8 @@ IN: hash2
|
|||
: assoc2 ( a b alist -- value )
|
||||
(assoc2) dup [ third ] when ; inline
|
||||
|
||||
: set-assoc2 ( value a b alist -- alist )
|
||||
[ rot 3array ] dip ?push ; inline
|
||||
:: set-assoc2 ( value a b alist -- alist )
|
||||
{ a b value } alist ?push ; inline
|
||||
|
||||
: hash2@ ( a b hash2 -- a b bucket hash2 )
|
||||
[ 2dup hashcode2 ] dip [ length mod ] keep ; inline
|
||||
|
|
@ -31,8 +33,8 @@ IN: hash2
|
|||
: hash2 ( a b hash2 -- value/f )
|
||||
hash2@ nth dup [ assoc2 ] [ 3drop f ] if ;
|
||||
|
||||
: set-hash2 ( a b value hash2 -- )
|
||||
[ -rot ] dip hash2@ [ set-assoc2 ] change-nth ;
|
||||
:: set-hash2 ( a b value hash2 -- )
|
||||
value a b hash2 hash2@ [ set-assoc2 ] change-nth ;
|
||||
|
||||
: alist>hash2 ( alist size -- hash2 )
|
||||
<hash2> [ over [ first3 ] dip set-hash2 ] reduce ; inline
|
||||
|
|
|
|||
|
|
@ -10,13 +10,13 @@ USING: io.launcher.unix.parser tools.test ;
|
|||
[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
|
||||
[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
|
||||
[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
|
||||
[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test
|
||||
[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test
|
||||
[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
|
||||
[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
|
||||
[ "'abc def' \"hey" tokenize-command ] must-fail
|
||||
[ "'abc def" tokenize-command ] must-fail
|
||||
[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
|
||||
[ V{ "abc\\ def" } ] [ "\"abc\\\\ def\"" tokenize-command ] unit-test
|
||||
[ V{ "abc\\ def" } ] [ " \"abc\\\\ def\"" tokenize-command ] unit-test
|
||||
[ V{ "abc\\ def" "hey" } ] [ "\"abc\\\\ def\" hey" tokenize-command ] unit-test
|
||||
[ V{ "abc def" "hey" } ] [ "\"abc def\" \"hey\"" tokenize-command ] unit-test
|
||||
[ "\"abc def\" \"hey" tokenize-command ] must-fail
|
||||
[ "\"abc def" tokenize-command ] must-fail
|
||||
[ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize-command ] unit-test
|
||||
|
||||
[
|
||||
V{
|
||||
|
|
|
|||
|
|
@ -1,33 +1,17 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: peg peg.parsers kernel sequences strings words ;
|
||||
USING: peg peg.ebnf arrays sequences strings kernel ;
|
||||
IN: io.launcher.unix.parser
|
||||
|
||||
! Our command line parser. Supported syntax:
|
||||
! foo bar baz -- simple tokens
|
||||
! foo\ bar -- escaping the space
|
||||
! 'foo bar' -- quotation
|
||||
! "foo bar" -- quotation
|
||||
: 'escaped-char' ( -- parser )
|
||||
"\\" token any-char 2seq [ second ] action ;
|
||||
|
||||
: 'quoted-char' ( delimiter -- parser' )
|
||||
'escaped-char'
|
||||
swap [ member? not ] curry satisfy
|
||||
2choice ; inline
|
||||
|
||||
: 'quoted' ( delimiter -- parser )
|
||||
dup 'quoted-char' repeat0 swap dup surrounded-by ;
|
||||
|
||||
: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
|
||||
|
||||
: 'argument' ( -- parser )
|
||||
"\"" 'quoted'
|
||||
"'" 'quoted'
|
||||
'unquoted' 3choice
|
||||
[ >string ] action ;
|
||||
|
||||
PEG: tokenize-command ( command -- ast/f )
|
||||
'argument' " " token repeat1 list-of
|
||||
" " token repeat0 tuck pack
|
||||
just ;
|
||||
EBNF: tokenize-command
|
||||
space = " "
|
||||
escaped-char = "\" .:ch => [[ ch ]]
|
||||
quoted = '"' (escaped-char | [^"])*:a '"' => [[ a ]]
|
||||
unquoted = (escaped-char | [^ "])+
|
||||
argument = (quoted | unquoted) => [[ >string ]]
|
||||
command = space* (argument:a space* => [[ a ]])+:c !(.) => [[ c ]]
|
||||
;EBNF
|
||||
|
|
|
|||
|
|
@ -192,7 +192,7 @@ M: object (client) ( remote -- client-in client-out local )
|
|||
] with-destructors ;
|
||||
|
||||
: <client> ( remote encoding -- stream local )
|
||||
[ (client) -rot ] dip <encoder-duplex> swap ;
|
||||
[ (client) ] dip swap [ <encoder-duplex> ] dip ;
|
||||
|
||||
SYMBOL: local-address
|
||||
|
||||
|
|
|
|||
|
|
@ -106,7 +106,8 @@ PRIVATE>
|
|||
|
||||
: deep-sequence>cons ( sequence -- cons )
|
||||
[ <reversed> ] keep nil
|
||||
[ tuck same? [ deep-sequence>cons ] when swons ] with reduce ;
|
||||
[ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ]
|
||||
with reduce ;
|
||||
|
||||
<PRIVATE
|
||||
:: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc )
|
||||
|
|
|
|||
|
|
@ -62,8 +62,7 @@ MACRO: match-cond ( assoc -- )
|
|||
} cond ;
|
||||
|
||||
: match-replace ( object pattern1 pattern2 -- result )
|
||||
-rot
|
||||
match [ "Pattern does not match" throw ] unless*
|
||||
[ match [ "Pattern does not match" throw ] unless* ] dip swap
|
||||
[ replace-patterns ] bind ;
|
||||
|
||||
: ?1-tail ( seq -- tail/f )
|
||||
|
|
|
|||
|
|
@ -164,9 +164,8 @@ M: plain-auth send-auth
|
|||
|
||||
: encode-header ( string -- string' )
|
||||
dup aux>> [
|
||||
"=?utf-8?B?"
|
||||
swap utf8 encode >base64
|
||||
"?=" 3append
|
||||
utf8 encode >base64
|
||||
"=?utf-8?B?" "?=" surround
|
||||
] when ;
|
||||
|
||||
ERROR: invalid-header-string string ;
|
||||
|
|
@ -205,7 +204,7 @@ ERROR: invalid-header-string string ;
|
|||
now timestamp>rfc822 "Date" set
|
||||
message-id "Message-Id" set
|
||||
"1.0" "MIME-Version" set
|
||||
"base64" "Content-Transfer-Encoding" set
|
||||
"quoted-printable" "Content-Transfer-Encoding" set
|
||||
{
|
||||
[ from>> "From" set ]
|
||||
[ to>> ", " join "To" set ]
|
||||
|
|
|
|||
|
|
@ -6,19 +6,21 @@ IN: sorting.slots
|
|||
|
||||
HELP: compare-slots
|
||||
{ $values
|
||||
{ "sort-specs" "a sequence of accessors ending with a comparator" }
|
||||
{ "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
|
||||
{ "obj1" object }
|
||||
{ "obj2" object }
|
||||
{ "sort-specs" "a sequence of accessors ending with a comparator" }
|
||||
{ "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
|
||||
}
|
||||
{ $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ;
|
||||
|
||||
HELP: sort-by-slots
|
||||
HELP: sort-by
|
||||
{ $values
|
||||
{ "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
|
||||
{ "seq'" sequence }
|
||||
}
|
||||
{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
|
||||
{ $examples
|
||||
"Sort by slot c, then b descending:"
|
||||
"Sort by slot a, then b descending:"
|
||||
{ $example
|
||||
"USING: accessors math.order prettyprint sorting.slots ;"
|
||||
"IN: scratchpad"
|
||||
|
|
@ -27,32 +29,18 @@ HELP: sort-by-slots
|
|||
" T{ sort-me f 2 3 } T{ sort-me f 3 2 }"
|
||||
" T{ sort-me f 4 3 } T{ sort-me f 2 1 }"
|
||||
"}"
|
||||
"{ { a>> <=> } { b>> >=< } } sort-by-slots ."
|
||||
"{ { a>> <=> } { b>> >=< } } sort-by ."
|
||||
"{\n T{ sort-me { a 2 } { b 3 } }\n T{ sort-me { a 2 } { b 1 } }\n T{ sort-me { a 3 } { b 2 } }\n T{ sort-me { a 4 } { b 3 } }\n}"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: split-by-slots
|
||||
{ $values
|
||||
{ "accessor-seqs" "a sequence of sequences of tuple accessors" }
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
|
||||
|
||||
HELP: sort-by
|
||||
{ $values
|
||||
{ "seq" sequence } { "sort-seq" "a sequence of comparators" }
|
||||
{ "seq'" sequence }
|
||||
}
|
||||
{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ;
|
||||
|
||||
ARTICLE: "sorting.slots" "Sorting by slots"
|
||||
"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
|
||||
"Comparing two objects by a sequence of slots:"
|
||||
{ $subsection compare-slots }
|
||||
"Sorting a sequence of tuples by a slot/comparator pairs:"
|
||||
{ $subsection sort-by-slots }
|
||||
"Sorting a sequence by a sequence of comparators:"
|
||||
{ $subsection sort-by } ;
|
||||
{ $subsection sort-by }
|
||||
{ $subsection sort-keys-by }
|
||||
{ $subsection sort-values-by } ;
|
||||
|
||||
ABOUT: "sorting.slots"
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ TUPLE: tuple2 d ;
|
|||
T{ sort-test f 1 1 11 }
|
||||
T{ sort-test f 2 5 3 }
|
||||
T{ sort-test f 2 5 2 }
|
||||
} { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
|
||||
} { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -42,43 +42,14 @@ TUPLE: tuple2 d ;
|
|||
T{ sort-test f 1 1 11 }
|
||||
T{ sort-test f 2 5 3 }
|
||||
T{ sort-test f 2 5 2 }
|
||||
} { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by-slots
|
||||
} { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{
|
||||
T{ sort-test { a 1 } { b 1 } { c 10 } }
|
||||
T{ sort-test { a 1 } { b 1 } { c 11 } }
|
||||
}
|
||||
{ T{ sort-test { a 1 } { b 3 } { c 9 } } }
|
||||
{
|
||||
T{ sort-test { a 2 } { b 5 } { c 3 } }
|
||||
T{ sort-test { a 2 } { b 5 } { c 2 } }
|
||||
}
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ sort-test f 1 3 9 }
|
||||
T{ sort-test f 1 1 10 }
|
||||
T{ sort-test f 1 1 11 }
|
||||
T{ sort-test f 2 5 3 }
|
||||
T{ sort-test f 2 5 2 }
|
||||
}
|
||||
{ { a>> human<=> } { b>> <=> } } [ sort-by-slots ] keep
|
||||
[ but-last-slice ] map split-by-slots [ >array ] map
|
||||
] unit-test
|
||||
|
||||
: split-test ( seq -- seq' )
|
||||
{ { a>> } { b>> } } split-by-slots ;
|
||||
|
||||
[ split-test ] must-infer
|
||||
[ { } ]
|
||||
[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by ] unit-test
|
||||
|
||||
[ { } ]
|
||||
[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
|
||||
|
||||
[ { } ]
|
||||
[ { } { } sort-by-slots ] unit-test
|
||||
[ { } { } sort-by ] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
|
|
@ -97,55 +68,7 @@ TUPLE: tuple2 d ;
|
|||
T{ sort-test f 6 f f T{ tuple2 f 3 } }
|
||||
T{ sort-test f 5 f f T{ tuple2 f 3 } }
|
||||
T{ sort-test f 6 f f T{ tuple2 f 2 } }
|
||||
} { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{
|
||||
T{ sort-test
|
||||
{ a 6 }
|
||||
{ tuple2 T{ tuple2 { d 1 } } }
|
||||
}
|
||||
}
|
||||
{
|
||||
T{ sort-test
|
||||
{ a 6 }
|
||||
{ tuple2 T{ tuple2 { d 2 } } }
|
||||
}
|
||||
}
|
||||
{
|
||||
T{ sort-test
|
||||
{ a 5 }
|
||||
{ tuple2 T{ tuple2 { d 3 } } }
|
||||
}
|
||||
}
|
||||
{
|
||||
T{ sort-test
|
||||
{ a 6 }
|
||||
{ tuple2 T{ tuple2 { d 3 } } }
|
||||
}
|
||||
T{ sort-test
|
||||
{ a 6 }
|
||||
{ tuple2 T{ tuple2 { d 3 } } }
|
||||
}
|
||||
}
|
||||
{
|
||||
T{ sort-test
|
||||
{ a 5 }
|
||||
{ tuple2 T{ tuple2 { d 4 } } }
|
||||
}
|
||||
}
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
|
||||
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } }
|
||||
T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } }
|
||||
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
|
||||
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
|
||||
T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
|
||||
} { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
|
||||
} { { tuple2>> d>> <=> } { a>> <=> } } sort-by
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,47 +1,28 @@
|
|||
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators.short-circuit fry kernel macros math.order
|
||||
sequences words sorting sequences.deep assocs splitting.monotonic
|
||||
math ;
|
||||
USING: arrays fry kernel math.order sequences sorting ;
|
||||
IN: sorting.slots
|
||||
|
||||
<PRIVATE
|
||||
: execute-comparator ( obj1 obj2 word -- <=>/f )
|
||||
execute( obj1 obj2 -- <=> ) dup +eq+ eq? [ drop f ] when ;
|
||||
|
||||
: short-circuit-comparator ( obj1 obj2 word -- comparator/? )
|
||||
execute( obj1 obj2 -- obj3 )
|
||||
dup +eq+ eq? [ drop f ] when ; inline
|
||||
: execute-accessor ( obj1 obj2 word -- obj1' obj2' )
|
||||
'[ _ execute( tuple -- value ) ] bi@ ;
|
||||
|
||||
: slot-comparator ( seq -- quot )
|
||||
[
|
||||
but-last-slice
|
||||
[ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat
|
||||
] [
|
||||
peek
|
||||
'[ @ _ short-circuit-comparator ]
|
||||
] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: compare-slots ( sort-specs -- <=> )
|
||||
: compare-slots ( obj1 obj2 sort-specs -- <=> )
|
||||
#! sort-spec: { accessors comparator }
|
||||
[ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
|
||||
[
|
||||
dup array? [
|
||||
unclip-last-slice
|
||||
[ [ execute-accessor ] each ] dip
|
||||
] when execute-comparator
|
||||
] with with map-find drop +eq+ or ;
|
||||
|
||||
: sort-by-slots ( seq sort-specs -- seq' )
|
||||
'[ _ compare-slots ] sort ;
|
||||
: sort-by-with ( seq sort-specs quot -- seq' )
|
||||
swap '[ _ bi@ _ compare-slots ] sort ; inline
|
||||
|
||||
MACRO: compare-seq ( seq -- quot )
|
||||
[ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
|
||||
: sort-by ( seq sort-specs -- seq' ) [ ] sort-by-with ;
|
||||
|
||||
: sort-by ( seq sort-seq -- seq' )
|
||||
'[ _ compare-seq ] sort ;
|
||||
: sort-keys-by ( seq sort-seq -- seq' ) [ first ] sort-by-with ;
|
||||
|
||||
: sort-keys-by ( seq sort-seq -- seq' )
|
||||
'[ [ first ] bi@ _ compare-seq ] sort ;
|
||||
|
||||
: sort-values-by ( seq sort-seq -- seq' )
|
||||
'[ [ second ] bi@ _ compare-seq ] sort ;
|
||||
|
||||
MACRO: split-by-slots ( accessor-seqs -- quot )
|
||||
[ [ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat
|
||||
[ = ] compose ] map
|
||||
'[ [ _ 2&& ] slice monotonic-slice ] ;
|
||||
: sort-values-by ( seq sort-seq -- seq' ) [ second ] sort-by-with ;
|
||||
|
|
|
|||
|
|
@ -3,20 +3,20 @@
|
|||
USING: accessors kernel arrays sequences math namespaces
|
||||
strings io fry vectors words assocs combinators sorting
|
||||
unicode.case unicode.categories math.order vocabs
|
||||
tools.vocabs unicode.data ;
|
||||
tools.vocabs unicode.data locals ;
|
||||
IN: tools.completion
|
||||
|
||||
: (fuzzy) ( accum ch i full -- accum i ? )
|
||||
index-from
|
||||
[
|
||||
[ swap push ] 2keep 1+ t
|
||||
:: (fuzzy) ( accum i full ch -- accum i full ? )
|
||||
ch i full index-from [
|
||||
:> i i accum push
|
||||
accum i 1+ full t
|
||||
] [
|
||||
drop f -1 f
|
||||
f -1 full f
|
||||
] if* ;
|
||||
|
||||
: fuzzy ( full short -- indices )
|
||||
dup length <vector> -rot 0 -rot
|
||||
[ -rot [ (fuzzy) ] keep swap ] all? 3drop ;
|
||||
dup [ length <vector> 0 ] curry 2dip
|
||||
[ (fuzzy) ] all? 3drop ;
|
||||
|
||||
: (runs) ( runs n seq -- runs n )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@ M: object file-spec>string ( file-listing spec -- string )
|
|||
: list-files-slow ( listing-tool -- array )
|
||||
[ path>> ] [ sort>> ] [ specs>> ] tri '[
|
||||
[ dup name>> file-info file-listing boa ] map
|
||||
_ [ sort-by-slots ] when*
|
||||
_ [ sort-by ] when*
|
||||
[ _ [ file-spec>string ] with map ] map
|
||||
] with-directory-entries ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@ io.encodings.utf8 hashtables kernel namespaces sequences
|
|||
vocabs.loader io combinators calendar accessors math.parser
|
||||
io.streams.string ui.tools.operations quotations strings arrays
|
||||
prettyprint words vocabs sorting sets classes math alien urls
|
||||
splitting ascii combinators.short-circuit alarms words.symbol ;
|
||||
splitting ascii combinators.short-circuit alarms words.symbol
|
||||
system ;
|
||||
IN: tools.scaffold
|
||||
|
||||
SYMBOL: developer-name
|
||||
|
|
@ -301,8 +302,10 @@ SYMBOL: examples-flag
|
|||
[ home ] dip append-path
|
||||
[ touch-file ] [ "Click to edit: " write <pathname> . ] bi ;
|
||||
|
||||
: scaffold-factor-boot-rc ( -- ) ".factor-boot-rc" scaffold-rc ;
|
||||
: scaffold-factor-boot-rc ( -- )
|
||||
os windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ;
|
||||
|
||||
: scaffold-factor-rc ( -- ) ".factor-rc" scaffold-rc ;
|
||||
: scaffold-factor-rc ( -- )
|
||||
os windows? "factor-rc" ".factor-rc" ? scaffold-rc ;
|
||||
|
||||
: scaffold-emacs ( -- ) ".emacs" scaffold-rc ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors arrays hashtables kernel models math namespaces
|
||||
make sequences quotations math.vectors combinators sorting
|
||||
binary-search vectors dlists deques models threads
|
||||
concurrency.flags math.order math.rectangles fry ;
|
||||
concurrency.flags math.order math.rectangles fry locals ;
|
||||
IN: ui.gadgets
|
||||
|
||||
! Values for orientation slot
|
||||
|
|
@ -66,8 +66,8 @@ M: gadget children-on nip children>> ;
|
|||
: ((fast-children-on)) ( gadget dim axis -- <=> )
|
||||
[ swap loc>> v- ] dip v. 0 <=> ;
|
||||
|
||||
: (fast-children-on) ( dim axis children -- i )
|
||||
-rot '[ _ _ ((fast-children-on)) ] search drop ;
|
||||
:: (fast-children-on) ( dim axis children -- i )
|
||||
children [ dim axis ((fast-children-on)) ] search drop ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
IN: windows.dinput.constants.tests
|
||||
USING: tools.test windows.dinput.constants.private ;
|
||||
|
||||
[ ] [ define-constants ] unit-test
|
||||
[ ] [ free-dinput-constants ] unit-test
|
||||
|
|
@ -27,12 +27,12 @@ SYMBOLS:
|
|||
|
||||
: (flag) ( thing -- integer )
|
||||
{
|
||||
{ [ dup word? ] [ execute ] }
|
||||
{ [ dup callable? ] [ call ] }
|
||||
{ [ dup word? ] [ execute( -- value ) ] }
|
||||
{ [ dup callable? ] [ call( -- value ) ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
: (flags) ( array -- )
|
||||
: (flags) ( array -- n )
|
||||
0 [ (flag) bitor ] reduce ;
|
||||
|
||||
: (DIOBJECTDATAFORMAT) ( pguid dwOfs dwType dwFlags alien -- alien )
|
||||
|
|
@ -63,14 +63,16 @@ SYMBOLS:
|
|||
] ;
|
||||
|
||||
: (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien )
|
||||
[ {
|
||||
[ set-DIDATAFORMAT-rgodf ]
|
||||
[ set-DIDATAFORMAT-dwNumObjs ]
|
||||
[ set-DIDATAFORMAT-dwDataSize ]
|
||||
[ set-DIDATAFORMAT-dwFlags ]
|
||||
[ set-DIDATAFORMAT-dwObjSize ]
|
||||
[ set-DIDATAFORMAT-dwSize ]
|
||||
} cleave ] keep ;
|
||||
[
|
||||
{
|
||||
[ set-DIDATAFORMAT-rgodf ]
|
||||
[ set-DIDATAFORMAT-dwNumObjs ]
|
||||
[ set-DIDATAFORMAT-dwDataSize ]
|
||||
[ set-DIDATAFORMAT-dwFlags ]
|
||||
[ set-DIDATAFORMAT-dwObjSize ]
|
||||
[ set-DIDATAFORMAT-dwSize ]
|
||||
} cleave
|
||||
] keep ;
|
||||
|
||||
: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
|
||||
[ "DIDATAFORMAT" heap-size "DIOBJECTDATAFORMAT" heap-size ] 4 ndip
|
||||
|
|
@ -78,9 +80,10 @@ SYMBOLS:
|
|||
"DIDATAFORMAT" <c-object> (DIDATAFORMAT) ;
|
||||
|
||||
: (malloc-guid-symbol) ( symbol guid -- )
|
||||
global swap '[ [
|
||||
_ execute [ byte-length malloc ] [ over byte-array>memory ] bi
|
||||
] unless* ] change-at ;
|
||||
'[
|
||||
_ execute( -- value )
|
||||
[ byte-length malloc ] [ over byte-array>memory ] bi
|
||||
] initialize ;
|
||||
|
||||
: define-guid-constants ( -- )
|
||||
{
|
||||
|
|
@ -105,7 +108,7 @@ SYMBOLS:
|
|||
} [ first2 (malloc-guid-symbol) ] each ;
|
||||
|
||||
: define-joystick-format-constant ( -- )
|
||||
c_dfDIJoystick2 global [ [
|
||||
c_dfDIJoystick2 [
|
||||
DIDF_ABSAXIS
|
||||
"DIJOYSTATE2" heap-size
|
||||
"DIJOYSTATE2" {
|
||||
|
|
@ -274,10 +277,10 @@ SYMBOLS:
|
|||
{ GUID_Slider_malloced "rglFSlider" 0 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE }
|
||||
{ GUID_Slider_malloced "rglFSlider" 1 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE }
|
||||
} <DIDATAFORMAT>
|
||||
] unless* ] change-at ;
|
||||
] initialize ;
|
||||
|
||||
: define-mouse-format-constant ( -- )
|
||||
c_dfDIMouse2 global [ [
|
||||
c_dfDIMouse2 [
|
||||
DIDF_RELAXIS
|
||||
"DIMOUSESTATE2" heap-size
|
||||
"DIMOUSESTATE2" {
|
||||
|
|
@ -293,13 +296,13 @@ SYMBOLS:
|
|||
{ GUID_Button_malloced "rgbButtons" 6 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 }
|
||||
{ GUID_Button_malloced "rgbButtons" 7 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 }
|
||||
} <DIDATAFORMAT>
|
||||
] unless* ] change-at ;
|
||||
] initialize ;
|
||||
|
||||
! Not a standard DirectInput format. Included for cross-platform niceness.
|
||||
! This format returns the keyboard keys in USB HID order rather than Windows
|
||||
! order
|
||||
: define-hid-keyboard-format-constant ( -- )
|
||||
c_dfDIKeyboard_HID global [ [
|
||||
c_dfDIKeyboard_HID [
|
||||
DIDF_RELAXIS
|
||||
256
|
||||
f {
|
||||
|
|
@ -560,10 +563,10 @@ SYMBOLS:
|
|||
{ GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 }
|
||||
{ GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 }
|
||||
} <DIDATAFORMAT>
|
||||
] unless* ] change-at ;
|
||||
] initialize ;
|
||||
|
||||
: define-keyboard-format-constant ( -- )
|
||||
c_dfDIKeyboard global [ [
|
||||
c_dfDIKeyboard [
|
||||
DIDF_RELAXIS
|
||||
256
|
||||
f {
|
||||
|
|
@ -824,7 +827,7 @@ SYMBOLS:
|
|||
{ GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 254 DIDFT_MAKEINSTANCE ] } 0 }
|
||||
{ GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 255 DIDFT_MAKEINSTANCE ] } 0 }
|
||||
} <DIDATAFORMAT>
|
||||
] unless* ] change-at ;
|
||||
] initialize ;
|
||||
|
||||
: define-format-constants ( -- )
|
||||
define-joystick-format-constant
|
||||
|
|
@ -837,7 +840,9 @@ SYMBOLS:
|
|||
define-format-constants ;
|
||||
|
||||
[ define-constants ] "windows.dinput.constants" add-init-hook
|
||||
define-constants
|
||||
|
||||
: uninitialize ( variable quot -- )
|
||||
[ global ] dip '[ _ when* f ] change-at ; inline
|
||||
|
||||
: free-dinput-constants ( -- )
|
||||
{
|
||||
|
|
@ -846,10 +851,11 @@ define-constants
|
|||
GUID_Slider_malloced GUID_Button_malloced GUID_Key_malloced GUID_POV_malloced GUID_Unknown_malloced
|
||||
GUID_SysMouse_malloced GUID_SysKeyboard_malloced GUID_Joystick_malloced GUID_SysMouseEm_malloced
|
||||
GUID_SysMouseEm2_malloced GUID_SysKeyboardEm_malloced GUID_SysKeyboardEm2_malloced
|
||||
} [ global [ [ free ] when* f ] change-at ] each
|
||||
} [ [ free ] uninitialize ] each
|
||||
|
||||
{
|
||||
c_dfDIKeyboard c_dfDIKeyboard_HID c_dfDIMouse2 c_dfDIJoystick2
|
||||
} [ global [ [ DIDATAFORMAT-rgodf free ] when* f ] change-at ] each ;
|
||||
} [ [ DIDATAFORMAT-rgodf free ] uninitialize ] each ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -59,17 +59,14 @@ t fuel-eval-res-flag set-global
|
|||
[ [ parse-lines ] with-compilation-unit call( -- ) ] curry
|
||||
[ print-error ] recover ;
|
||||
|
||||
: (fuel-eval-each) ( lines -- )
|
||||
[ (fuel-eval) ] each ;
|
||||
|
||||
: (fuel-eval-usings) ( usings -- )
|
||||
[ "USE: " prepend ] map
|
||||
(fuel-eval-each) fuel-forget-error fuel-forget-output ;
|
||||
(fuel-eval) fuel-forget-error fuel-forget-output ;
|
||||
|
||||
: (fuel-eval-in) ( in -- )
|
||||
[ dup "IN: " prepend (fuel-eval) in set ] when* ;
|
||||
[ dup "IN: " prepend 1array (fuel-eval) in set ] when* ;
|
||||
|
||||
: (fuel-eval-in-context) ( lines in usings -- )
|
||||
(fuel-begin-eval)
|
||||
[ (fuel-eval-usings) (fuel-eval-in) "\n" join (fuel-eval) ] with-string-writer
|
||||
[ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer
|
||||
(fuel-end-eval) ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: jamshred.log
|
|||
LOG: (jamshred-log) DEBUG
|
||||
|
||||
: with-jamshred-log ( quot -- )
|
||||
"jamshred" swap with-logging ;
|
||||
"jamshred" swap with-logging ; inline
|
||||
|
||||
: jamshred-log ( message -- )
|
||||
[ (jamshred-log) ] with-jamshred-log ; ! ugly...
|
||||
|
|
|
|||
|
|
@ -1,34 +1,33 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: calendar kernel openal sequences threads ;
|
||||
IN: openal.example
|
||||
USING: openal kernel alien threads sequences calendar ;
|
||||
|
||||
: play-hello ( -- )
|
||||
init-openal
|
||||
1 gen-sources
|
||||
first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param
|
||||
source-play
|
||||
1000 milliseconds sleep ;
|
||||
init-openal
|
||||
1 gen-sources
|
||||
first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param
|
||||
source-play
|
||||
1000 milliseconds sleep ;
|
||||
|
||||
: (play-file) ( source -- )
|
||||
100 milliseconds sleep
|
||||
dup source-playing? [ (play-file) ] [ drop ] if ;
|
||||
100 milliseconds sleep
|
||||
dup source-playing? [ (play-file) ] [ drop ] if ;
|
||||
|
||||
: play-file ( filename -- )
|
||||
init-openal
|
||||
create-buffer-from-file
|
||||
1 gen-sources
|
||||
first dup >r AL_BUFFER rot set-source-param r>
|
||||
dup source-play
|
||||
check-error
|
||||
(play-file) ;
|
||||
init-openal
|
||||
create-buffer-from-file
|
||||
1 gen-sources
|
||||
first dup [ AL_BUFFER rot set-source-param ] dip
|
||||
dup source-play
|
||||
check-error
|
||||
(play-file) ;
|
||||
|
||||
: play-wav ( filename -- )
|
||||
init-openal
|
||||
create-buffer-from-wav
|
||||
1 gen-sources
|
||||
first dup >r AL_BUFFER rot set-source-param r>
|
||||
dup source-play
|
||||
check-error
|
||||
(play-file) ;
|
||||
init-openal
|
||||
create-buffer-from-wav
|
||||
1 gen-sources
|
||||
first dup [ AL_BUFFER rot set-source-param ] dip
|
||||
dup source-play
|
||||
check-error
|
||||
(play-file) ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: openal.backend alien.c-types kernel alien alien.syntax
|
||||
shuffle combinators.lib ;
|
||||
USING: alien.c-types alien.syntax combinators generalizations
|
||||
kernel openal.backend ;
|
||||
IN: openal.other
|
||||
|
||||
LIBRARY: alut
|
||||
|
|
@ -9,6 +9,6 @@ LIBRARY: alut
|
|||
FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
|
||||
|
||||
M: object load-wav-file ( filename -- format data size frequency )
|
||||
0 <int> f <void*> 0 <int> 0 <int>
|
||||
[ 0 <char> alutLoadWAVFile ] 4keep
|
||||
>r >r >r *int r> *void* r> *int r> *int ;
|
||||
0 <int> f <void*> 0 <int> 0 <int>
|
||||
[ 0 <char> alutLoadWAVFile ] 4 nkeep
|
||||
{ [ *int ] [ *void* ] [ *int ] [ *int ] } spread ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue