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

Merge remote-tracking branch 'origin/master' into modern-harvey2

modern-harvey2
Doug Coleman 2018-01-27 09:43:21 -06:00
parent f5853bda82 f976d97983
commit 5d8b912216
132 changed files with 1809 additions and 546 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
.travis.yml
View File

@ -44,12 +44,5 @@ before_install:
wget https://github.com/vmt/udis86/archive/v1.7.2.tar.gz && tar xzvf v1.7.2.tar.gz &&
( cd udis86-1.7.2/ && ./autogen.sh && ./configure --enable-shared=yes && make && sudo make install ) &&
( [[ "$TRAVIS_OS_NAME" != "osx" ]] && sudo ldconfig || true )
script: >
( echo "=== Bootstrap ===" ; ./build.sh net-bootstrap < /dev/null ; ret=$? ; echo "=== $ret ==="; [ $ret == 0 ] ) &&
( echo "=== Factor Configure Postgresql ===" ; ./factor -e='USING: db.postgresql namespaces memory ; T{ postgresql-db f "localhost" f f f f "postgres" "" } \ postgresql-db set-global save' ; ret=$? ; echo "=== $ret ==="; [ $ret == 0 ] ) &&
( echo "=== Factor Configure Imap ===" ; ./factor -e='USING: imap namespaces memory environment accessors ; T{ imap-settings { host "imap.gmail.com" } } "FACTOR_IMAP_USER" os-env >>email "FACTOR_IMAP_PASSWORD" os-env >>password \ imap-settings set-global save' ; ret=$? ; echo "=== $ret ==="; [ $ret == 0 ] ) &&
( echo "=== Mkdir ===" ; mkdir -p mason/builds ; ret=$? ; echo "=== $ret ==="; [ $ret == 0 ] ) &&
( echo "=== Factor tests ===" ; cd mason/builds && ../../factor -e='USING: namespaces tools.test mason.test benchmark ; f long-unit-tests-enabled? set-global t benchmarks-disabled? set-global do-all' < /dev/null | awk 'NR<1000 || /^Loading resource|Unit Test/' ; ret=${PIPESTATUS[0]} ; echo "=== $ret ==="; [ $ret == 0 ]) &&
( echo "=== Factor report === " ; cd mason && ../factor -e='USING: mason.config mason.report namespaces ; "." builds-dir [ successful-report ] with-variable' ; ret=$? ; echo "=== $ret ==="; [ $ret == 0 ]) &&
( echo "=== Dump report === " ;[[ "$TRAVIS_OS_NAME" != "osx" ]] && links -dump mason/report || cat mason/report ; ret=$? ; echo "=== $ret ==="; [ $ret == 0 ]) &&
[ ! -s mason/test-all-errors ]
script:
- ./build.sh net-bootstrap < /dev/null

2
LICENSE.txt
View File

@ -1,4 +1,4 @@
Copyright (c) 2017, Slava Pestov, et al.
Copyright (c) 2018, Slava Pestov, et al.
All rights reserved.
Redistribution and use in source and binary forms, with or without

2
README.md
View File

@ -75,7 +75,7 @@ Some other simple things you can try in the listener:
1000 [1,b] sum .
4 iota [
4 <iota> [
"Happy Birthday " write
2 = "dear NAME" "to You" ? print
] each

2
basis/biassocs/biassocs-docs.factor
View File

@ -12,7 +12,7 @@ HELP: <bihash>
{ $values { "biassoc" biassoc } }
{ $description "Creates a new biassoc using a pair of hashtables for underlying storage." } ;
HELP: once-at
HELP: set-at-once
{ $values { "value" object } { "key" object } { "assoc" assoc } }
{ $description "If the assoc does not contain the given key, adds the key/value pair to the assoc, otherwise does nothing." } ;

4
basis/biassocs/biassocs.factor
View File

@ -17,11 +17,11 @@ M: biassoc at* from>> at* ; inline
M: biassoc value-at* to>> at* ; inline
: once-at ( value key assoc -- )
: set-at-once ( value key assoc -- )
2dup key? [ 3drop ] [ set-at ] if ;
M: biassoc set-at
[ from>> set-at ] [ swapd to>> once-at ] 3bi ;
[ from>> set-at ] [ swapd to>> set-at-once ] 3bi ;
ERROR: no-biassoc-deletion ;

2
basis/boxes/boxes.factor
View File

@ -31,5 +31,5 @@ PRIVATE>
: ?box ( box -- value/f ? )
dup occupied>> [ box-unsafe> t ] [ drop f f ] if ; inline
: if-box? ( box quot -- )
: if-box? ( box quot: ( value -- ) -- )
[ ?box ] dip [ drop ] if ; inline

3
basis/calendar/parser/parser.factor
View File

@ -169,5 +169,4 @@ MACRO: attempt-all-quots ( quots -- quot )
[ instant read-00 >>hour read-00 >>minute ] with-string-reader ;
: hms>duration ( str -- duration )
[ read-hms ] with-string-reader
instant swap >>second swap >>minute swap >>hour ;
[ 0 0 0 read-hms <duration> ] with-string-reader ;

12
basis/cocoa/touchbar/touchbar.factor
View File

@ -7,17 +7,17 @@ IN: cocoa.touchbar
: make-touchbar ( seq self -- touchbar )
[ NSTouchBar -> alloc -> init dup ] dip -> setDelegate: {
[ swap <CFStringArray> { void { id SEL id } } ?-> setDefaultItemIdentifiers: ]
[ swap <CFStringArray> { void { id SEL id } } ?-> setCustomizationAllowedItemIdentifiers: ]
[ swap <CFStringArray> -> setDefaultItemIdentifiers: ]
[ swap <CFStringArray> -> setCustomizationAllowedItemIdentifiers: ]
[ nip ]
} 2cleave ;
:: make-NSTouchBar-button ( self identifier label-string action-string -- button )
NSCustomTouchBarItem send: alloc
identifier <CFString> { id { id SEL id } } ?send: \initWithIdentifier: :> item
NSCustomTouchBarItem -> alloc
identifier <CFString> -> initWithIdentifier: :> item
NSButton
label-string <CFString>
self
action-string lookup-selector { id { id SEL id id SEL } } ?send: \buttonWithTitle:target:action: :> button
item button send: \setView:
action-string lookup-selector -> buttonWithTitle:target:action: :> button
item button -> setView:
item ;

4
basis/combinators/smart/smart.factor
View File

@ -142,7 +142,7 @@ MACRO: map-reduce-outputs ( quot mapper reducer -- quot )
MACRO: smart-reduce ( reduce-quots -- quot )
unzip [ [ ] like ] bi@ dup length dup '[
[ @ ] dip [ @ _ cleave-curry _ spread* ] each
_ dip [ @ _ cleave-curry _ spread* ] each
] ;
MACRO: smart-map-reduce ( map-reduce-quots -- quot )
@ -154,7 +154,7 @@ MACRO: smart-map-reduce ( map-reduce-quots -- quot )
MACRO: smart-2reduce ( 2reduce-quots -- quot )
unzip [ [ ] like ] bi@ dup length dup '[
[ @ ] 2dip
_ 2dip
[ @ _ [ cleave-curry ] [ cleave-curry ] bi _ spread* ] 2each
] ;

2
basis/compiler/cfg/intrinsics/simd/backend/backend.factor
View File

@ -70,7 +70,7 @@ M: ##horizontal-shl-vector-imm insn-available? rep>> %horizontal-shl-vector-imm-
M: ##horizontal-shr-vector-imm insn-available? rep>> %horizontal-shr-vector-imm-reps member? ;
: [vector-op-checked] ( #dup quot -- quot )
'[ _ ndup [ @ ] { } make dup [ insn-available? ] all? ] ;
'[ _ ndup _ { } make dup [ insn-available? ] all? ] ;
GENERIC#: >vector-op-cond 2 ( quot #pick #dup -- quotpair )
M:: callable >vector-op-cond ( quot #pick #dup -- quotpair )

2
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -107,7 +107,7 @@ RENAMING: assign "[ vreg>reg ]" "[ vreg>reg ]" "[ vreg>reg ]"
: change-insn-gc-roots ( gc-map-insn quot: ( x -- x ) -- )
[ gc-map>> ] dip [ swap gc-roots>> swap map! drop ]
[ '[ [ [ @ ] bi@ ] assoc-map ] change-derived-roots drop ] 2bi ; inline
[ '[ [ _ bi@ ] assoc-map ] change-derived-roots drop ] 2bi ; inline
: spill-required? ( live-interval root-leaders n -- ? )
[ [ vreg>> ] dip sets::in? ] [ swap covers? ] bi-curry* bi or ;

2
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -300,7 +300,7 @@ CONSTANT: lookup-table-at-max 256
\ at* [ at-quot ] 1 define-partial-eval
: diff-quot ( seq -- quot: ( seq' -- seq'' ) )
[ tester ] keep '[ members [ @ ] reject _ set-like ] ;
[ tester ] keep '[ members _ reject _ set-like ] ;
M\\ sets::set diff [ diff-quot ] 1 define-partial-eval

2
basis/concurrency/count-downs/count-downs-tests.factor
View File

@ -1,5 +1,5 @@
USING: concurrency.count-downs threads kernel tools.test ;
IN: concurrency.count-downs.tests`
IN: concurrency.count-downs.tests
{ } [ 0 <count-down> await ] unit-test

1
basis/concurrency/distributed/authors.txt
View File

@ -1 +1,2 @@
Chris Double
Alexander Ilin

43
basis/concurrency/distributed/distributed.factor
View File

@ -1,9 +1,11 @@
! Copyright (C) 2005 Chris Double. All Rights Reserved.
! Copyright (C) 2018 Alexander Ilin.
! See http://factorcode.org/license.txt for BSD license.
USING: serialize sequences concurrency.messaging threads io
io.servers io.encodings.binary assocs init
arrays namespaces kernel accessors ;
FROM: io.sockets => host-name <inet> with-client ;
USING: accessors arrays assocs concurrency.messaging
continuations destructors fry init io io.encodings.binary
io.servers io.sockets io.streams.duplex kernel namespaces
sequences serialize threads ;
FROM: concurrency.messaging => send ;
IN: concurrency.distributed
<PRIVATE
@ -11,6 +13,9 @@ IN: concurrency.distributed
: registered-remote-threads ( -- hash )
\ registered-remote-threads get-global ;
: thread-connections ( -- hash )
\ thread-connections get-global ;
PRIVATE>
: register-remote-thread ( thread name -- )
@ -25,8 +30,9 @@ PRIVATE>
SYMBOL: local-node
: handle-node-client ( -- )
deserialize
[ first2 get-remote-thread send ] [ stop-this-server ] if* ;
deserialize [
first2 get-remote-thread send handle-node-client
] [ stop-this-server ] if* ;
: <node-server> ( addrspec -- threaded-server )
binary <threaded-server>
@ -41,19 +47,38 @@ TUPLE: remote-thread node id ;
C: <remote-thread> remote-thread
TUPLE: connection remote stream local ;
C: <connection> connection
: connect ( remote-thread -- )
[ node>> dup binary <client> <connection> ]
[ thread-connections set-at ] bi ;
: disconnect ( remote-thread -- )
thread-connections delete-at*
[ stream>> dispose ] [ drop ] if ;
: with-connection ( remote-thread quot -- )
'[ connect @ ] over [ disconnect ] curry [ ] cleanup ; inline
: send-remote-message ( message node -- )
binary [ serialize ] with-client ;
: send-to-connection ( message connection -- )
stream>> [ serialize flush ] with-stream* ;
M: remote-thread send ( message thread -- )
[ id>> 2array ] [ node>> ] bi
send-remote-message ;
[ id>> 2array ] [ node>> ] [ thread-connections at ] tri
[ nip send-to-connection ] [ send-remote-message ] if* ;
M: thread (serialize) ( obj -- )
id>> [ local-node get insecure>> ] dip <remote-thread> (serialize) ;
: stop-node ( -- )
local-node get insecure>> f swap send-remote-message ;
f local-node get insecure>> send-remote-message ;
[
H{ } clone \ registered-remote-threads set-global
H{ } clone \ thread-connections set-global
] "remote-thread-registry" add-startup-hook

17
basis/concurrency/mailboxes/mailboxes-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax kernel arrays calendar ;
USING: help.markup help.syntax kernel calendar sequences ;
IN: concurrency.mailboxes
HELP: <mailbox>
@ -29,15 +29,19 @@ HELP: block-if-empty
{ $values { "mailbox" mailbox }
{ "timeout" { $maybe duration } }
}
{ $description "Block the thread if the mailbox is empty." } ;
{ $description "Block the thread for " { $snippet "timeout" } " if the mailbox is empty." } ;
HELP: mailbox-get
{ $values { "mailbox" mailbox } { "obj" object } }
{ $description "Get the first item put into the mailbox. If it is empty, the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ;
HELP: mailbox-get-all-timeout
{ $values { "mailbox" mailbox } { "timeout" { $maybe duration } } { "seq" sequence } }
{ $description "Blocks the thread for " { $snippet "timeout" } " if the mailbox is empty, then removes all objects in the mailbox and returns a sequence containing the objects." } ;
HELP: mailbox-get-all
{ $values { "mailbox" mailbox } { "array" array } }
{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ;
{ $values { "mailbox" mailbox } { "seq" sequence } }
{ $description "Blocks the thread if the mailbox is empty, then removes all objects in the mailbox and returns a sequence containing the objects." } ;
HELP: while-mailbox-empty
{ $values { "mailbox" mailbox }
@ -69,7 +73,10 @@ ARTICLE: "concurrency.mailboxes" "Mailboxes"
mailbox-get-timeout?
}
"Emptying out a mailbox:"
{ $subsections mailbox-get-all }
{ $subsections
mailbox-get-all
mailbox-get-all-timeout
}
"Adding an element:"
{ $subsections mailbox-put }
"Testing if a mailbox is empty:"

2
basis/concurrency/mailboxes/mailboxes-tests.factor
View File

@ -42,7 +42,7 @@ IN: concurrency.mailboxes.tests
mailbox-get
] unit-test
{ { "foo" "bar" } } [
{ V{ "foo" "bar" } } [
<mailbox>
"foo" over mailbox-put
"bar" over mailbox-put

20
basis/concurrency/mailboxes/mailboxes.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists deques threads sequences continuations namespaces
math quotations words kernel arrays assocs init system
concurrency.conditions accessors locals fry vocabs.loader ;
USING: accessors concurrency.conditions continuations deques
destructors dlists fry kernel locals sequences threads
vocabs.loader ;
IN: concurrency.mailboxes
TUPLE: mailbox { threads dlist } { data dlist } ;
@ -47,13 +47,10 @@ M: mailbox mailbox-get-timeout block-if-empty data>> pop-back ;
: mailbox-get ( mailbox -- obj )
f mailbox-get-timeout ; inline
: mailbox-get-all-timeout ( mailbox timeout -- array )
block-if-empty
[ dup mailbox-empty? not ]
[ dup data>> pop-back ]
produce nip ;
: mailbox-get-all-timeout ( mailbox timeout -- seq )
block-if-empty data>> [ ] collector [ slurp-deque ] dip ;
: mailbox-get-all ( mailbox -- array )
: mailbox-get-all ( mailbox -- seq )
f mailbox-get-all-timeout ;
: while-mailbox-empty ( mailbox quot -- )
@ -68,8 +65,9 @@ M: mailbox mailbox-get-timeout block-if-empty data>> pop-back ;
f swap mailbox-get-timeout? ; inline
: wait-for-close-timeout ( mailbox timeout -- )
over disposed>>
[ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;
'[
_ 2dup wait-for-mailbox wait-for-close-timeout
] unless-disposed ;
: wait-for-close ( mailbox -- )
f wait-for-close-timeout ;

2
basis/cpu/x86/assembler/assembler-docs.factor
View File

@ -49,7 +49,7 @@ HELP: zero-extendable?
{ $values { "imm" integer } { "?" boolean } }
{ $description "All positive 32-bit numbers are zero extendable except for 0 which is the value used for relocations." } ;
ARTICLE: "cpu.x86.assembler" "X86 assembler"
ARTICLE: "cpu.x86.assembler" "CPU x86 assembler"
"This vocab implements an assembler for x86 architectures."
$nl
"General instructions:"

16
basis/cpu/x86/features/features-docs.factor Normal file
View File

@ -0,0 +1,16 @@
! Copyright (C) 2017 Alexander Ilin.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel math quotations strings ;
IN: cpu.x86.features
HELP: instruction-count
{ $values
{ "n" number }
}
{ $description "The word returns the CPU's Timestamp Counter: " { $url "http://en.wikipedia.org/wiki/Time_Stamp_Counter" } "." } ;
ARTICLE: "cpu.x86.features" "CPU x86 features"
{ $vocab-link "cpu.x86.features" }
;
ABOUT: "cpu.x86.features"

8
basis/formatting/formatting.factor
View File

@ -9,6 +9,8 @@ math.functions.integer-logs splitting multiline ;
FROM: math.parser.private => format-float ;
IN: formatting
ERROR: unknown-format-directive value ;
<PRIVATE
: compose-all ( seq -- quot )
@ -91,8 +93,6 @@ IN: formatting
[ [ ".0" ?tail drop ] [ drop ] if-zero ] bi
] [ format-decimal-simple ] if ;
ERROR: unknown-printf-directive ;
EBNF: parse-printf [=[
zero = "0" => [[ char: 0 ]]
@ -126,7 +126,7 @@ fmt-E = digits "E" => [[ first '[ _ format-scientific >upper ] ]]
fmt-f = digits "f" => [[ first '[ _ format-decimal ] ]]
fmt-x = "x" => [[ [ >integer >hex ] ]]
fmt-X = "X" => [[ [ >integer >hex >upper ] ]]
unknown = (.)* => [[ unknown-printf-directive ]]
unknown = (.)* => [[ "" like unknown-format-directive ]]
strings_ = fmt-c|fmt-C|fmt-s|fmt-S|fmt-u
strings = pad width strings_ => [[ <reversed> compose-all ]]
@ -235,7 +235,7 @@ fmt-X = "X" => [[ [ >time ] ]]
fmt-y = "y" => [[ [ year>> 100 mod pad-00 ] ]]
fmt-Y = "Y" => [[ [ year>> number>string ] ]]
fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]]
unknown = (.)* => [[ "Unknown directive" throw ]]
unknown = (.)* => [[ "" like unknown-format-directive ]]
formats_ = fmt-%|fmt-a|fmt-A|fmt-b|fmt-B|fmt-c|fmt-d|fmt-H|fmt-I|
fmt-j|fmt-m|fmt-M|fmt-p|fmt-S|fmt-U|fmt-w|fmt-W|fmt-x|

2
basis/game/input/x11/x11.factor
View File

@ -78,7 +78,7 @@ M: linux x>hid-bit-order
} ; inline
: x-bits>hid-bits ( bit-array -- bit-array )
256 <iota> [ 2array ] { } 2map-as [ first ] filter values
256 <iota> { } zip-as [ first ] filter values
x>hid-bit-order [ nth ] curry map
256 <bit-array> swap [ t swap pick set-nth ] each ;

2
basis/gdk/gl/ffi/ffi.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2010 Anton Gorenko.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.libraries alien.syntax combinators
gobject-introspection kernel system vocabs vocabs.loader ;
gobject-introspection kernel system vocabs ;
IN: gdk.gl.ffi
<<

3
basis/gtk/ffi/ffi.factor
View File

@ -2,8 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.destructors alien.libraries
alien.syntax combinators gobject-introspection
gobject-introspection.standard-types kernel pango.ffi system
vocabs ;
gobject-introspection.standard-types kernel pango.ffi system vocabs ;
IN: gtk.ffi
<<

2
basis/interval-maps/interval-maps-tests.factor
View File

@ -1,5 +1,5 @@
USING: kernel namespaces interval-maps tools.test ;
IN: interval-maps.test
IN: interval-maps.tests
SYMBOL: test

2
basis/inverse/inverse-tests.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: inverse tools.test arrays math kernel sequences
math.functions math.constants continuations combinators.smart ;
IN: inverse-tests
IN: inverse.tests
{ 2 } [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
[ { 3 4 } [ dup 2array ] undo ] must-fail

2
basis/io/encodings/strict/strict-tests.factor
View File

@ -1,6 +1,6 @@
USING: io.encodings.strict io.encodings.ascii tools.test
arrays io.encodings.string ;
IN: io.encodings.strict.test
IN: io.encodings.strict.tests
{ { 0xfffd } } [ { 128 } ascii decode >array ] unit-test
[ { 128 } ascii strict decode ] must-fail

7
basis/io/launcher/unix/unix.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data assocs combinators
continuations environment io.backend io.backend.unix
continuations environment fry io.backend io.backend.unix
io.files.private io.files.unix io.launcher io.launcher.private
io.pathnames io.ports kernel libc math namespaces sequences
simple-tokenizer strings system unix unix.ffi unix.process ;
@ -92,7 +92,7 @@ IN: io.launcher.unix
M: unix (current-process) ( -- handle ) getpid ;
M: unix (run-process) ( process -- pid )
[ spawn-process ] curry [ ] with-fork ;
'[ _ spawn-process ] [ ] with-fork ;
M: unix (kill-process) ( process -- )
[ handle>> SIGTERM ] [ group>> ] bi {
@ -102,8 +102,7 @@ M: unix (kill-process) ( process -- )
} case io-error ;
: find-process ( handle -- process )
processes get swap [ nip swap handle>> = ] curry
assoc-find 2drop ;
processes get keys [ handle>> = ] with find nip ;
TUPLE: signal n ;

2
basis/linked-assocs/linked-assocs-tests.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel linked-assocs math sequences
tools.test ;
IN: linked-assocs.test
IN: linked-assocs.tests
{ { 1 2 3 } } [
<linked-hash> 1 "b" pick set-at

3
basis/math/bitwise/bitwise-docs.factor
View File

@ -470,10 +470,11 @@ $nl
W-
W*
}
"Converting a number to the nearest even/odd:"
"Converting a number to the nearest even/odd/signed:"
{ $subsections
>even
>odd
>signed
}
"Bitfields:"
{ $subsections

2
basis/math/functions/functions.factor
View File

@ -214,7 +214,7 @@ CONSTANT: log10-2 0x1.34413509f79ffp-2
: (bignum-log) ( n log-quot: ( x -- y ) log-2 -- log )
[ dup ] dip '[
dup representable-as-float?
[ >float @ ] [ frexp [ @ ] [ _ * ] bi* + ] if
[ >float @ ] [ frexp _ [ _ * ] bi* + ] if
] call ; inline
PRIVATE>

2
basis/math/matrices/matrices.factor
View File

@ -237,7 +237,7 @@ M: sequence square-cols
[ length ] keep [ <array> ] with { } map-as ;
: make-matrix-with-indices ( m n quot -- matrix )
[ [ <iota> ] bi@ ] dip '[ @ ] cartesian-map ; inline
[ [ <iota> ] bi@ ] dip cartesian-map ; inline
: null-matrix? ( matrix -- ? ) empty? ; inline

6
basis/openssl/libcrypto/libcrypto-tests.factor
View File

@ -8,7 +8,11 @@ USING:
tools.test ;
IN: openssl.libcrypto.tests
{ t } [ "factorcode.org:80" BIO_new_connect bio_st? ] unit-test
{ t 1 } [
"factorcode.org:80" BIO_new_connect [
bio_st?
] keep BIO_free
] unit-test
{ 1 1 } [
"factorcode.org:80" BIO_new_connect [

2
basis/pack/pack.factor
View File

@ -123,7 +123,7 @@ PRIVATE>
MACRO: unpack ( str -- quot )
expand-pack-format
[ [ ch>packed-length ] { } map-as start/end ]
[ [ unpack-table at '[ @ ] ] { } map-as ] bi
[ [ unpack-table at ] { } map-as ] bi
[ '[ [ _ _ ] dip <slice> @ ] ] 3map
'[ [ _ cleave ] output>array ] ;

6
basis/porter-stemmer/porter-stemmer-tests.factor
View File

@ -1,6 +1,6 @@
IN: porter-stemmer.tests
USING: arrays io kernel porter-stemmer sequences tools.test
io.files io.encodings.utf8 ;
USING: arrays assocs io kernel porter-stemmer sequences
tools.test io.files io.encodings.utf8 ;
{ 0 } [ "xa" consonant-seq ] unit-test
{ 0 } [ "xxaa" consonant-seq ] unit-test
@ -60,5 +60,5 @@ io.files io.encodings.utf8 ;
"vocab:porter-stemmer/test/voc.txt" utf8 file-lines
[ stem ] map
"vocab:porter-stemmer/test/output.txt" utf8 file-lines
[ 2array ] 2map [ first2 = ] reject
zip [ = ] assoc-reject
] unit-test

2
basis/random/windows/windows.factor
View File

@ -46,7 +46,7 @@ ERROR: acquire-crypto-context-failed provider type error ;
initialize-crypto-context ; inline
M: windows-crypto-context random-bytes* ( n windows-crypto-context -- bytes )
handle>> swap [ ] [ <byte-array> ] bi
handle>> swap dup <byte-array>
[ CryptGenRandom win32-error=0/f ] keep ;
! Some Windows installations still don't work, so just set

2
basis/regexp/regexp-tests.factor
View File

@ -1,6 +1,6 @@
USING: arrays regexp tools.test kernel sequences regexp.parser
regexp.private eval strings multiline accessors ;
IN: regexp-tests
IN: regexp.tests
{ f } [ "b" "a*" <regexp> matches? ] unit-test
{ t } [ "" "a*" <regexp> matches? ] unit-test

8
basis/tools/completion/completion-tests.factor
View File

@ -1,5 +1,4 @@
USING: assocs kernel sequences tools.test ;
IN: tools.completion
USING: assocs kernel sequences tools.completion tools.test ;
{ f } [ "abc" "def" fuzzy ] unit-test
{ V{ 4 5 6 } } [ "set-nth" "nth" fuzzy ] unit-test
@ -30,3 +29,8 @@ IN: tools.completion
{ f } [ { "char:" } complete-char? ] unit-test
{ t } [ { "char:" "" } complete-char? ] unit-test
{ t } [ { "char:" "a" } complete-char? ] unit-test
{ f } [ { "FROM:" } complete-vocab-words? ] unit-test
{ f } [ { "FROM:" "math" } complete-vocab-words? ] unit-test
{ t } [ { "FROM:" "math" "=>" } complete-vocab-words? ] unit-test
{ f } [ { "FROM:" "math" "=>" "+" ";" } complete-vocab-words? ] unit-test
{ f } [ { "BOOM:" "math" "=>" "+" } complete-vocab-words? ] unit-test

16
basis/tools/completion/completion.factor
View File

@ -84,6 +84,9 @@ PRIVATE>
: vocabs-matching ( str -- seq )
all-disk-vocabs-recursive filter-vocabs name-completions ;
: vocab-words-matching ( str vocab -- seq )
vocab-words name-completions ;
: chars-matching ( str -- seq )
name-map keys dup zip completions ;
@ -114,8 +117,10 @@ PRIVATE>
<PRIVATE
: (complete-single-vocab?) ( str -- ? )
{ "IN:" "USE:" "UNUSE:" "QUALIFIED:" "QUALIFIED-WITH:" }
member? ; inline
{
"IN:" "USE:" "UNUSE:" "QUALIFIED:"
"QUALIFIED-WITH:" "FROM:" "EXCLUDE:"
} member? ; inline
: complete-single-vocab? ( tokens -- ? )
dup last empty? [
@ -136,6 +141,13 @@ PRIVATE>
: complete-vocab? ( tokens -- ? )
{ [ complete-single-vocab? ] [ complete-vocab-list? ] } 1|| ;
: complete-vocab-words? ( tokens -- ? )
harvest chop-; {
[ length 3 >= ]
[ first { "FROM:" "EXCLUDE:" } member? ]
[ third "=>" = ]
} 1&& ;
<PRIVATE
: complete-token? ( tokens token -- ? )

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

@ -59,7 +59,7 @@ delete-staging-images
! { } [ "bunny" shake-and-bake 2559640 small-enough? ] long-unit-test
{ } [ "bunny" shake-and-bake 2700000 small-enough? ] long-unit-test
{ } [ "gpu.demos.bunny" shake-and-bake 3630000 small-enough? ] long-unit-test
{ } [ "gpu.demos.bunny" shake-and-bake 3640000 small-enough? ] long-unit-test
os macosx? [
[ ] [ "webkit-demo" shake-and-bake 600000 small-enough? ] long-unit-test

24
basis/tools/scaffold/scaffold.factor
View File

@ -17,12 +17,7 @@ ERROR: not-a-vocab-root string ;
<PRIVATE
: vocab-root? ( string -- ? )
trim-tail-separators
vocab-roots get member? ;
: contains-dot? ( string -- ? ) ".." swap subseq? ;
: contains-separator? ( string -- ? ) [ path-separator? ] any? ;
trim-tail-separators vocab-roots get member? ;
: ensure-vocab-exists ( string -- string )
dup loaded-vocab-names member? [ no-vocab ] unless ;
@ -41,8 +36,7 @@ ERROR: not-a-vocab-root string ;
[ ] [ replace-vocab-separators ] bi* append-path ;
: vocab>path ( vocab -- path )
check-vocab
[ find-vocab-root ] keep vocab-root/vocab>path ;
check-vocab [ find-vocab-root ] keep vocab-root/vocab>path ;
: vocab-root/vocab/file>path ( vocab-root vocab file -- path )
[ vocab-root/vocab>path ] dip append-path ;
@ -147,12 +141,9 @@ M: string add-using drop ;
M: object add-using ( object -- )
vocabulary>> using get [ adjoin ] [ drop ] if* ;
: 4bl ( -- )
" " write ; inline
: ($values.) ( array -- )
[
4bl
" " write
[ bl ] [
"{ " write
dup array? [ first ] when
@ -186,16 +177,13 @@ M: object add-using ( object -- )
] when* ;
: class-description. ( word -- )
drop
"{ $class-description \"\" } ;" print ;
drop "{ $class-description \"\" } ;" print ;
: symbol-description. ( word -- )
drop
"{ $var-description \"\" } ;" print ;
drop "{ $var-description \"\" } ;" print ;
: $description. ( word -- )
drop
"{ $description \"\" } ;" print ;
drop "{ $description \"\" } ;" print ;
: docs-body. ( word/symbol -- )
{

13
basis/ui/backend/cocoa/cocoa.factor
View File

@ -76,10 +76,10 @@ M: pasteboard set-clipboard-contents
! after register-window.
dup { 0 0 } = [
drop
ui-windows get-global length 1 <= [ send: center ] [
ui-windows get-global last second window-loc>>
dupd first2 <CGPoint> send: \cascadeTopLeftFromPoint:
send: \setFrameTopLeftPoint:
worlds get-global length 1 <= [ -> center ] [
worlds get-global last second window-loc>>
dupd first2 <CGPoint> -> \cascadeTopLeftFromPoint:
-> \setFrameTopLeftPoint:
] if
] [ first2 <CGPoint> send: \setFrameTopLeftPoint: ] if ;
@ -222,8 +222,13 @@ M: cocoa-ui-backend (with-ui)
stop-io-thread
init-thread-timer
reset-thread-timer
<<<<<<< HEAD
NSApp send: run
] ui-running
=======
NSApp -> run
] with-ui-running
>>>>>>> origin/master
] with-cocoa ;
cocoa-ui-backend ui-backend set-global

14
basis/ui/backend/cocoa/views/views.factor
View File

@ -162,16 +162,24 @@ CONSTANT: selector>action H{
[ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
: touchbar-commands ( -- commands/f gadget )
world get [
world get-global [
children>> [
class-of "commands" word-prop
"touchbar" of dup [ commands>> ] when
] map-find
] [ f f ] if* ;
TUPLE: send-touchbar-command target command ;
M: send-touchbar-command send-queued-gesture
[ target>> ] [ command>> ] bi invoke-command ;
: touchbar-invoke-command ( n -- )
[ touchbar-commands ] dip over
[ rot nth second invoke-command ] [ 3drop ] if ;
[ touchbar-commands ] dip over [
rot nth second
send-touchbar-command queue-gesture notify-ui-thread
yield
] [ 3drop ] if ;
<CLASS: FactorView < NSOpenGLView
COCOA-PROTOCOL: NSTextInput

3
basis/ui/backend/gtk/gtk.factor
View File

@ -78,6 +78,7 @@ M: gtk-clipboard set-clipboard-contents
:: with-timer ( quot -- )
<timer-funcs> &free
GSource heap-size g_source_new &g_source_unref :> source
source G_PRIORITY_DEFAULT_IDLE g_source_set_priority
source f g_source_attach drop
[ quot call( -- ) ]
[ source g_source_destroy ] [ ] cleanup ;
@ -512,7 +513,7 @@ M: gtk-ui-backend (with-ui)
[
[ [ gtk_main ] with-timer ] with-event-loop
] with-destructors
] ui-running ;
] with-ui-running ;
M: gtk-ui-backend stop-event-loop
gtk_main_quit ;

2
basis/ui/backend/windows/windows.factor
View File

@ -712,7 +712,7 @@ M: windows-ui-backend (with-ui)
start-ui
event-loop
] [ cleanup-win32-ui ] [ ] cleanup
] ui-running ;
] with-ui-running ;
M: windows-ui-backend beep ( -- )
0 MessageBeep drop ;

2
basis/ui/backend/x11/x11.factor
View File

@ -327,7 +327,7 @@ M: x11-ui-backend (with-ui) ( quot -- )
event-loop
] with-xim
] with-x
] ui-running ;
] with-ui-running ;
M: x11-ui-backend beep ( -- )
dpy get 100 XBell drop ;

2
basis/ui/event-loop/event-loop-docs.factor
View File

@ -3,4 +3,4 @@ IN: ui.event-loop
HELP: event-loop?
{ $values { "?" boolean } }
{ $description { $link t } " if there is active windows." } ;
{ $description { $link t } " if there are active windows." } ;

2
basis/ui/event-loop/event-loop.factor
View File

@ -7,7 +7,7 @@ IN: ui.event-loop
: event-loop? ( -- ? )
{
{ [ graft-queue deque-empty? not ] [ t ] }
{ [ ui-windows get-global empty? not ] [ t ] }
{ [ worlds get-global empty? not ] [ t ] }
[ f ]
} cond ;

2
basis/ui/gadgets/editors/editors-docs.factor
View File

@ -8,7 +8,7 @@ HELP: <multiline-editor>
{ $description "Creates a new multi-line editor gadget." } ;
HELP: editor
{ $class-description "An editor is a control for editing a multi-line passage of text stored in a " { $link document } " model. Editors are crated by calling " { $link <editor> } "."
{ $class-description "An editor is a control for editing a multi-line passage of text stored in a " { $link document } " model. Editors are created by calling " { $link <editor> } "."
$nl
"Editors have the following slots:"
{ $list

16
basis/ui/gadgets/gadgets-docs.factor
View File

@ -6,6 +6,11 @@ HELP: <gadget>
{ $values { "gadget" "a new " { $link gadget } } }
{ $description "Creates a new gadget." } ;
HELP: children-on
{ $values { "rect" rect } { "gadget" gadget } { "seq" "a sequence of gadgets" } }
{ $contract "Outputs a sequence of gadgets which potentially intersect a rectangle in the co-ordinate system of the gadget." }
{ $notes "This does not have to be an accurate intersection test, and simply returning " { $link children>> } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ;
HELP: control-value
{ $values { "control" gadget } { "value" object } }
{ $description "Outputs the value of the control's model." } ;
@ -19,6 +24,10 @@ HELP: notify
{ $description "Notifies the gadget that it has a graft message to handle." }
{ $see-also graft* ungraft* } ;
HELP: notify-ui-thread
{ $description "Notifies the UI thread that there is work to do." }
{ $see-also ui-notify-flag } ;
HELP: nth-gadget
{ $values { "n" "a non-negative integer" } { "gadget" gadget } { "child" gadget } }
{ $description "Outputs the " { $snippet "n" } "th child of the gadget." }
@ -37,11 +46,6 @@ HELP: user-input*
{ $values { "str" string } { "gadget" gadget } { "?" boolean } }
{ $contract "Handle free-form textual input while the gadget has keyboard focus." } ;
HELP: children-on
{ $values { "rect" rect } { "gadget" gadget } { "seq" "a sequence of gadgets" } }
{ $contract "Outputs a sequence of gadgets which potentially intersect a rectangle in the co-ordinate system of the gadget." }
{ $notes "This does not have to be an accurate intersection test, and simply returning " { $link children>> } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ;
HELP: pick-up
{ $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" { $maybe gadget } } }
{ $description "Outputs the child at a point in the gadget's co-ordinate system. This word recursively descends the gadget hierarchy, and so outputs the deepest child." } ;
@ -70,7 +74,7 @@ HELP: relayout
HELP: relayout-1
{ $values { "gadget" gadget } }
{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout } ", this does not propagate requests up to the parent, and so this word should only be used when the gadget's internal layout or appearance has changed, but the dimensions have not." } ;
{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout } ", this does not propagate requests up to the parent, and so this word should be used when the gadget's internal layout or appearance has changed, but the dimensions have not." } ;
{ relayout relayout-1 } related-words

23
basis/ui/gadgets/worlds/worlds.factor
View File

@ -54,7 +54,9 @@ TUPLE: world-attributes
gadgets
{ pixel-format-attributes initial: $ default-world-pixel-format-attributes }
{ window-controls initial: $ default-world-window-controls }
pref-dim ;
pref-dim
{ fill initial: 1 }
{ orientation initial: $ vertical } ;
: <world-attributes> ( -- world-attributes )
world-attributes new ; inline
@ -102,8 +104,7 @@ TUPLE: world-attributes
ERROR: no-world-found ;
: find-gl-context ( gadget -- )
find-world dup
[ set-gl-context ] [ no-world-found ] if ;
find-world [ set-gl-context ] [ no-world-found ] if* ;
: (request-focus) ( child world ? -- )
pick parent>> pick eq? [
@ -141,6 +142,8 @@ M: world apply-world-attributes
[ grab-input?>> >>grab-input? ]
[ gadgets>> dup sequence? [ [ 1 track-add ] each ] [ 1 track-add ] if ]
[ pref-dim>> >>pref-dim ]
[ fill>> >>fill ]
[ orientation>> >>orientation ]
} cleave ;
: <world> ( world-attributes -- world )
@ -212,14 +215,12 @@ ui-error-hook [ [ rethrow ] ] initialize
: draw-world ( world -- )
dup draw-world? [
dup world [
[
dup [ draw-world* ] with-gl-context
flush-layout-cache-hook get call( -- )
] [
swap f >>active? <world-error> throw
] recover
] with-variable
[
dup [ draw-world* ] with-gl-context
flush-layout-cache-hook get call( -- )
] [
swap f >>active? <world-error> throw
] recover
] [ drop ] if ;
world

19
basis/ui/gestures/gestures-docs.factor
View File

@ -30,7 +30,7 @@ HELP: parents-handle-gesture?
HELP: propagate-gesture
{ $values { "gesture" "a gesture" } { "gadget" gadget } }
{ $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } "." } ;
{ $description "Calls " { $link handle-gesture } " on every parent of the " { $snippet "gadget" } ", starting with the " { $snippet "gadget" } " itself." } ;
HELP: motion
{ $class-description "Mouse motion gesture." }
@ -261,7 +261,9 @@ ARTICLE: "gesture-differences" "Gesture handling differences between platforms"
}
"On Windows, " { $link key-up } " gestures are not reported for all keyboard events."
$nl
{ $link "multitouch-gestures" } " are only supported on Mac OS X." ;
{ $link "multitouch-gestures" } " are only supported on Mac OS X."
$nl
{ $link "filedrop-gestures" } " are only supported on Windows." ;
ARTICLE: "ui-gestures" "UI gestures"
"User actions such as keyboard input and mouse button clicks deliver " { $emphasis "gestures" } " to gadgets. If the direct receiver of the gesture does not handle it, the gesture is passed on to the receiver's parent, and this way it travels up the gadget hierarchy. Gestures which are not handled at some point are ignored."
@ -283,6 +285,7 @@ $nl
{ $subsections
"mouse-gestures"
"multitouch-gestures"
"filedrop-gestures"
}
"Guidelines for cross-platform applications:"
{ $subsections "gesture-differences" }
@ -418,6 +421,18 @@ $nl
zoom-out-action
} ;
ARTICLE: "filedrop-gestures" "File drop gestures"
"File drop gestures are only supported on Windows. When user drags-and-drops a file or a group of files from another application, the following gesture can be handled:"
{ $subsections file-drop } ;
HELP: file-drop
{ $class-description "File drop gesture. The " { $slot "mods" } " slot contains the keyboard modifiers active at the time of the drop (see " { $link "keyboard-gestures" } "). The " { $link dropped-files } " global variable contains an array of full paths of the files that were dropped."
$nl
"The " { $link hand-loc } " global variable contains the drop location. If the user dropped files onto the non-client area of a window (the caption or the border), the gesture will not be triggered, but the contents of the " { $link dropped-files } " will be updated." } ;
HELP: dropped-files
{ $var-description "The global variable holds an array of full paths of the files that were dropped by the last " { $link file-drop } " gesture." } ;
ARTICLE: "action-gestures" "Action gestures"
"Action gestures exist to keep keyboard shortcuts for common application operations consistent."
{ $subsections

5
basis/ui/gestures/gestures.factor
View File

@ -79,6 +79,9 @@ M: user-input-tuple send-queued-gesture
TUPLE: drag # ; C: <drag> drag
TUPLE: button-up mods # ; C: <button-up> button-up
TUPLE: button-down mods # ; C: <button-down> button-down
TUPLE: file-drop mods ; C: <file-drop> file-drop
SYMBOL: dropped-files
SINGLETONS:
motion
@ -357,6 +360,8 @@ M: button-down gesture>string
#>> [ " " % # ] when*
] "" make ;
M: file-drop gesture>string drop "Drop files" ;
M: left-action gesture>string drop "Swipe left" ;
M: right-action gesture>string drop "Swipe right" ;

3
basis/ui/operations/operations-docs.factor
View File

@ -17,6 +17,9 @@ HELP: +keyboard+
HELP: +primary+
{ $description "A key which may be set in the hashtable passed to " { $link define-operation } ". If set to a true value, this operation becomes the default operation performed when a presentation matching the operation's predicate is clicked with the mouse." } ;
HELP: +secondary+
{ $description "A key which may be set in the hashtable passed to " { $link define-operation } ". If set to a true value, this operation becomes the default operation performed when " { $snippet "RET" } " is pressed while a presentation matching the operation's predicate is selected in a list." } ;
HELP: operation
{ $description "An abstraction for an operation which may be performed on a presentation."
$nl

4
basis/ui/render/render.factor
View File

@ -104,9 +104,9 @@ M: gadget gadget-foreground dup interior>> pen-foreground ;
] with-translation ;
: draw-border ( object -- )
dup boundary>> dup [
dup boundary>> [
origin get [ draw-boundary ] with-translation
] [ 2drop ] if ;
] [ drop ] if* ;
PRIVATE>

2
basis/ui/tools/browser/browser.factor
View File

@ -226,6 +226,8 @@ browser-gadget "multi-touch" f {
} define-command-map
browser-gadget "touchbar" f {
{ f com-back }
{ f com-forward }
{ f com-home }
{ f browser-help }
{ f glossary }

11
basis/ui/tools/listener/completion/completion.factor
View File

@ -28,9 +28,13 @@ SLOT: history
TUPLE: word-completion manifest ;
C: <word-completion> word-completion
TUPLE: vocab-word-completion vocab-name ;
C: <vocab-word-completion> vocab-word-completion
SINGLETONS: vocab-completion color-completion char-completion
path-completion history-completion ;
UNION: definition-completion word-completion vocab-completion ;
UNION: definition-completion word-completion
vocab-word-completion vocab-completion ;
UNION: listener-completion definition-completion
color-completion char-completion path-completion history-completion ;
@ -40,6 +44,7 @@ GENERIC: completion-quot ( interactor completion-mode -- quot )
2nip '[ [ { } ] _ if-empty ] ; inline
M: word-completion completion-quot [ words-matching ] (completion-quot) ;
M: vocab-word-completion completion-quot nip vocab-name>> '[ _ vocab-words-matching ] ;
M: vocab-completion completion-quot [ vocabs-matching ] (completion-quot) ;
M: color-completion completion-quot [ colors-matching ] (completion-quot) ;
M: char-completion completion-quot [ chars-matching ] (completion-quot) ;
@ -54,6 +59,7 @@ M: history-completion completion-element drop one-line-elt ;
GENERIC: completion-banner ( completion-mode -- string )
M: word-completion completion-banner drop "Words" ;
M: vocab-word-completion completion-banner drop "Words" ;
M: vocab-completion completion-banner drop "Vocabularies" ;
M: color-completion completion-banner drop "Colors" ;
M: char-completion completion-banner drop "Unicode code point names" ;
@ -80,6 +86,8 @@ M: word-completion row-color
[ color: dark-gray ]
} cond 2nip ;
M: vocab-word-completion row-color 2drop COLOR: black ;
M: vocab-completion row-color
drop dup vocab? [
name>> ".private" tail? color: dark-red color: black ?
@ -98,6 +106,7 @@ M: color-completion row-color
{ [ dup complete-char? ] [ 2drop char-completion ] }
{ [ dup complete-color? ] [ 2drop color-completion ] }
{ [ dup complete-pathname? ] [ 2drop path-completion ] }
{ [ dup complete-vocab-words? ] [ nip harvest second <vocab-word-completion> ] }
[ drop <word-completion> ]
} cond ;

13
basis/ui/tools/listener/listener.factor
View File

@ -56,6 +56,9 @@ M: word-completion (word-at-caret)
'[ _ _ search-manifest ] [ drop f ] recover
] [ drop f ] if* ;
M: vocab-word-completion (word-at-caret)
vocab-name>> lookup-word ;
M: char-completion (word-at-caret) 2drop f ;
M: path-completion (word-at-caret) 2drop f ;
@ -444,6 +447,11 @@ interactor "completion" f {
\ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
: com-file-drop ( -- files )
dropped-files get-global ;
\ com-file-drop H{ { +nullary+ t } { +listener+ t } } define-command
listener-gadget "toolbar" f {
{ f restart-listener }
{ T{ key-down f { A+ } "u" } com-auto-use }
@ -472,6 +480,11 @@ listener-gadget "touchbar" f {
{ f com-help }
} define-command-map
listener-gadget "file-drop" "Files can be drag-and-dropped onto the listener."
{
{ T{ file-drop f f } com-file-drop }
} define-command-map
M: listener-gadget graft*
[ call-next-method ] [ restart-listener ] bi ;

16
basis/ui/tools/tools-docs.factor
View File

@ -1,8 +1,8 @@
USING: editors help.markup help.syntax summary inspector io io.styles
listener parser prettyprint tools.walker ui.commands
ui.gadgets.panes ui.gadgets.presentations ui.operations
ui.tools.operations ui.tools.common vocabs see
help.tips ;
ui.gadgets.panes ui.gadgets.presentations ui.gestures
ui.operations ui.tools.operations ui.tools.common
vocabs see help.tips ;
IN: ui.tools
ARTICLE: "starting-ui-tools" "Starting the UI tools"
@ -41,9 +41,12 @@ $nl
"Dropping a source file onto the Factor icon in the dock runs the source file in the listener."
$nl
"If you install " { $strong "Factor.app" } " in your " { $strong "Applications" } " folder, then other applications will be able to call Factor via the System Services feature. For example, you can select some text in " { $strong "TextEdit.app" } ", then invoke the " { $strong "TextEdit->Services->Factor->Evaluate Selection" } " menu item, which will replace the selected text with the result of evaluating it in Factor."
;
ARTICLE: "ui-windows" "Functionality specific to Windows"
"Files can be dropped from other applications onto the listener window to push their names onto the stack:"
{ $subsections "filedrop-gestures" } ;
ARTICLE: "ui-tools" "UI developer tools"
"The " { $vocab-link "ui.tools" } " vocabulary hierarchy implements a collection of simple developer tools."
{ $subsections "starting-ui-tools" }
@ -65,7 +68,10 @@ $nl
"ui.tools.deploy"
}
"Platform-specific features:"
{ $subsections "ui-cocoa" } ;
{ $subsections
"ui-cocoa"
"ui-windows"
} ;
TIP: "All UI developer tools support a common set of " { $link "ui-shortcuts" } ". Each individual tool has its own shortcuts as well; the F1 key is context-sensitive." ;

52
basis/ui/ui-docs.factor
View File

@ -6,18 +6,34 @@ vocabs.loader ;
IN: ui
HELP: ui-windows
{ $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ;
{ ui-windows open-window find-window world-attributes } related-words
HELP: close-window
{ $values { "gadget" gadget } }
{ $description "Close the native window containing " { $snippet "gadget" } "." } ;
HELP: open-window
{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } }
{ $description "Opens a native window containing " { $snippet "gadget" } " with the specified attributes. If a string is provided, it is used as the window title; otherwise, the window attributes are specified in a " { $link world-attributes } " tuple." } ;
HELP: close-window
{ $values { "gadget" gadget } }
{ $description "Close the native window containing " { $snippet "gadget" } "." } ;
HELP: set-fullscreen
{ $values { "gadget" gadget } { "?" boolean } }
{ $description "Sets and unsets fullscreen mode for the gadget's world." } ;
HELP: set-up-window
{ $values { "world" world } }
{ $description "Initializes the window that shows the world." } ;
HELP: ui-thread
{ $var-description "Holds a reference to the running UI thread. This variable is used to ensure that there can only be one UI thread running at the same time." }
{ $see-also start-ui-thread } ;
HELP: ui-running?
{ $values { "?" boolean } }
{ $description "Whether the UI is running or not." } ;
HELP: worlds
{ $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ;
{ worlds open-window find-window world-attributes } related-words
HELP: world-attributes
{ $values { "world-class" class } { "title" string } { "status" gadget } { "gadgets" sequence } { "pixel-format-attributes" sequence } { "window-controls" sequence } }
@ -31,32 +47,28 @@ HELP: world-attributes
{ { $snippet "window-controls" } " is a sequence of " { $link "ui.gadgets.worlds-window-controls" } " that will be placed in the window." }
} ;
HELP: set-fullscreen
{ $values { "gadget" gadget } { "?" boolean } }
{ $description "Sets and unsets fullscreen mode for the gadget's world." } ;
HELP: set-up-window
{ $values { "world" world } }
{ $description "Initializes the window that shows the world." } ;
HELP: fullscreen?
{ $values { "gadget" gadget } { "?" boolean } }
{ $description "Queries the gadget's world to see if it is running in fullscreen mode." } ;
{ fullscreen? set-fullscreen } related-words
HELP: find-windows
{ $values { "quot" { $quotation ( world -- ? ) } } { "seq" sequence } }
{ $description "Finds all native windows such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting an empty sequence if no such gadget could be found. The front-most native window is the last in the " { $snippet "seq" } "." } ;
HELP: find-window
{ $values { "quot" { $quotation ( world -- ? ) } } { "world/f" { $maybe world } } }
{ $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
HELP: register-window
{ $values { "world" world } { "handle" "a backend-specific handle" } }
{ $description "Adds a window to the global " { $link ui-windows } " variable." }
{ $description "Adds a window to the global " { $link worlds } " variable." }
{ $notes "This word should only be called by the UI backend. User code can open new windows with " { $link open-window } "." } ;
HELP: unregister-window
{ $values { "handle" "a backend-specific handle" } }
{ $description "Removes a window from the global " { $link ui-windows } " variable." }
{ $description "Removes a window from the global " { $link worlds } " variable." }
{ $notes "This word should only be called only by the UI backend, and not user code." } ;
HELP: (with-ui)
@ -114,7 +126,7 @@ ARTICLE: "building-ui" "Building user interfaces"
"ui-geometry"
"ui-layouts"
"gadgets"
"ui-windows"
"ui-worlds"
"ui.gadgets.status-bar"
}
{ $see-also "models" } ;
@ -148,13 +160,13 @@ ARTICLE: "ui-geometry" "Gadget geometry"
children-on
} ;
ARTICLE: "ui-windows" "Top-level windows"
ARTICLE: "ui-worlds" "Top-level windows"
"Opening a top-level window:"
{ $subsections open-window }
"Finding top-level windows:"
{ $subsections find-window }
"Top-level windows are stored in a global variable:"
{ $subsections ui-windows }
{ $subsections worlds }
"When a gadget is displayed in a top-level window, or added to a parent which is already showing in a top-level window, a generic word is called allowing the gadget to perform initialization tasks:"
{ $subsections graft* }
"When the gadget is removed from a parent shown in a top-level window, or when the top-level window is closed, a corresponding generic word is called to clean up:"

46
basis/ui/ui.factor
View File

@ -11,10 +11,10 @@ IN: ui
<PRIVATE
! Assoc mapping aliens to gadgets
SYMBOL: ui-windows
! Assoc mapping aliens to worlds
SYMBOL: worlds
: window ( handle -- world ) ui-windows get-global at ;
: window ( handle -- world ) worlds get-global at ;
: register-window ( world handle -- )
! Add the new window just below the topmost window. Why?
@ -23,15 +23,15 @@ SYMBOL: ui-windows
! in the new window when it appears) Factor doesn't get
! confused and send workspace operations to the new window,
! etc.
swap 2array ui-windows get-global push
ui-windows get-global dup length 1 >
swap 2array worlds get-global push
worlds get-global dup length 1 >
[ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ;
: unregister-window ( handle -- )
ui-windows [ [ first = ] with reject ] change-global ;
worlds [ [ first = ] with reject ] change-global ;
: raised-window ( world -- )
ui-windows get-global
worlds get-global
[ [ second eq? ] with find drop ] keep
[ nth ] [ remove-nth! drop ] [ nip ] 2tri push ;
@ -105,7 +105,7 @@ M: world ungraft*
<dlist> \ graft-queue set-global
100 <vector> \ layout-queue set-global
<dlist> \ gesture-queue set-global
V{ } clone ui-windows set-global ;
V{ } clone worlds set-global ;
: update-hand ( world -- )
dup hand-world get-global eq?
@ -132,28 +132,35 @@ M: world ungraft*
redraw-worlds
send-queued-gestures ;
: ui-running ( quot -- )
t \ ui-running set-global
[ f \ ui-running set-global ] [ ] cleanup ; inline
SYMBOL: ui-running
: with-ui-running ( quot -- )
t ui-running set-global
[ f ui-running set-global ] [ ] cleanup ; inline
PRIVATE>
: find-window ( quot: ( world -- ? ) -- world/f )
[ ui-windows get-global values ] dip
: find-windows ( quot: ( world -- ? ) -- seq )
[ worlds get-global values ] dip
'[ dup children>> [ ] [ nip first ] if-empty @ ]
find-last nip ; inline
filter ; inline
: find-window ( quot: ( world -- ? ) -- world/f )
find-windows ?last ; inline
: ui-running? ( -- ? )
\ ui-running get-global ;
ui-running get-global ;
<PRIVATE
SYMBOL: ui-thread
: update-ui-loop ( -- )
! Note the logic: if update-ui fails, we open an error window and
! run one iteration of update-ui. If that also fails, well, the
! whole UI subsystem is broken so we throw the error to terminate
! the update-ui-loop.
[ ui-running? ]
[ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
[
ui-notify-flag get lower-flag
[ update-ui ] [
@ -164,7 +171,8 @@ PRIVATE>
] while ;
: start-ui-thread ( -- )
[ update-ui-loop ] "UI update" spawn drop ;
[ self ui-thread set-global update-ui-loop ]
"UI update" spawn drop ;
: start-ui ( quot -- )
call( -- ) notify-ui-thread start-ui-thread ;
@ -197,7 +205,7 @@ PRIVATE>
find-world raise-window* ;
: topmost-window ( -- world )
ui-windows get-global last second ;
worlds get-global last second ;
HOOK: close-window ui-backend ( gadget -- )
@ -205,7 +213,7 @@ M: object close-window
find-world [ ungraft ] when* ;
[
f \ ui-running set-global
f ui-running set-global
<flag> ui-notify-flag set-global
] "ui" add-startup-hook

59
basis/windows/dragdrop-listener/dragdrop-listener.factor
View File

@ -1,26 +1,18 @@
! Copyright (C) 2008, 2009 Joe Groff, Slava Pestov.
! Copyright (C) 2017 Alexander Ilin.
! Copyright (C) 2017-2018 Alexander Ilin.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.accessors alien.data alien.strings
classes.struct io.encodings.utf16n kernel make math namespaces
prettyprint sequences specialized-arrays
ui.gadgets.worlds ui.tools.listener windows.com
windows.com.wrapper windows.kernel32 windows.ole32
windows.shell32 windows.types ;
specialized-arrays.instances.alien.c-types.ushort
ui.backend.windows ui.gadgets.worlds ui.gestures
ui.tools.listener windows.com windows.com.wrapper
windows.dropfiles windows.kernel32 windows.ole32 windows.shell32
windows.types ;
SPECIALIZED-ARRAY: WCHAR
IN: windows.dragdrop-listener
: filecount-from-hdrop ( hdrop -- n )
0xFFFFFFFF f 0 DragQueryFile ;
: filenames-from-hdrop ( hdrop -- filenames )
dup filecount-from-hdrop <iota>
[
2dup f 0 DragQueryFile 1 + ! get size of filename buffer
dup WCHAR <c-array>
[ swap DragQueryFile drop ] keep
utf16n alien>string
] with map ;
CONSTANT: E_OUTOFMEMORY -2147024882 ! 0x8007000e
: handle-data-object ( handler: ( hdrop -- x ) data-object -- filenames )
FORMATETC <struct>
@ -42,9 +34,9 @@ IN: windows.dragdrop-listener
: filecount-from-data-object ( data-object -- n )
\ filecount-from-hdrop swap handle-data-object ;
TUPLE: listener-dragdrop hWnd last-drop-effect ;
TUPLE: listener-dragdrop world last-drop-effect ;
: <listener-dragdrop> ( hWnd -- object )
: <listener-dragdrop> ( world -- object )
DROPEFFECT_NONE listener-dragdrop boa ;
<<
@ -55,27 +47,24 @@ SYMBOL: +listener-dragdrop-wrapper+
{
{ IDropTarget {
[ ! HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
[
2drop filecount-from-data-object
1 = DROPEFFECT_COPY DROPEFFECT_NONE ?
dup
] dip 0 set-alien-unsigned-4
>>last-drop-effect drop
DROPEFFECT_COPY swap 0 set-alien-unsigned-4 3drop
DROPEFFECT_COPY >>last-drop-effect drop
S_OK
] [ ! HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
[ 2drop last-drop-effect>> ] dip 0 set-alien-unsigned-4
[
2drop
[ world>> children>> first hand-gadget set-global ]
[ last-drop-effect>> ] bi
] dip 0 set-alien-unsigned-4
S_OK
] [ ! HRESULT DragLeave ( )
drop S_OK
] [ ! HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )
[
2drop nip
filenames-from-data-object
dup length 1 = [
first unparse [ "USE: parser " % % " run-file" % ] "" make
eval-listener
DROPEFFECT_COPY
] [ drop DROPEFFECT_NONE ] if
filenames-from-data-object dropped-files set-global
key-modifiers <file-drop> hand-gadget get-global propagate-gesture
DROPEFFECT_COPY
] dip 0 set-alien-unsigned-4
S_OK
]
@ -84,6 +73,10 @@ SYMBOL: +listener-dragdrop-wrapper+
>>
: dragdrop-listener-window ( -- )
world get handle>> hWnd>> dup <listener-dragdrop>
+listener-dragdrop-wrapper+ get-global com-wrap
[ RegisterDragDrop check-ole32-error ] with-com-interface ;
world get dup <listener-dragdrop>
+listener-dragdrop-wrapper+ get-global com-wrap [
[ handle>> hWnd>> ] dip
2dup RegisterDragDrop dup E_OUTOFMEMORY =
[ drop ole-initialize RegisterDragDrop ] [ 2nip ] if
check-ole32-error
] with-com-interface ;

1
basis/windows/dropfiles/authors.txt Normal file
View File

@ -0,0 +1 @@
Alexander Ilin

53
basis/windows/dropfiles/dropfiles-docs.factor Normal file
View File

@ -0,0 +1,53 @@
! Copyright (C) 2017-2018 Alexander Ilin.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays help.markup help.syntax kernel math
ui.backend.windows ui.gestures windows.types ;
IN: windows.dropfiles
ABOUT: "windows-dropfiles"
ARTICLE: "windows-dropfiles" "File drop gesture for Windows"
"A window has to declare whether it wants to accept dropped files. By default files are rejected:"
{ $subsections
accept-files
reject-files
world-accept-files
world-reject-files
}
"When user drops files onto a window, the target gadget may handle the corresponding gesture:"
{ $subsections file-drop }
"Implementation details:"
{ $subsections
"about-dragdrop"
init-message-filter
} ;
ARTICLE: "about-dragdrop" "File drag-and-drop in Windows"
"There are two mechanisms in Windows that can be used to drag-and-drop files across applications:"
{ $list
{ { $snippet "WM_DROPFILES" } " - was introduced back in the early days, it is a message that's posted to a window's message queue after the user has dropped some files on it. While handling the message, the application can fetch the list of the dropped files and the mouse position of the drop." }
{ { $snippet "IDropTarget" } " - an OLE reinvention of the same. It provides more fine-grained capabilities of dynamically accepting or rejecting the drop based on the mouse location and the contents of the drop, while the user still drags the files over the window." }
}
"Windows Vista has introduced some security features that made it impossible for the OLE to work between two applications with different security tokens. E.g. if one of the applications is ran with administrative privileges, and the other is without, the OLE drag-and-drop will not work between them."
$nl
"By default, WM_DROPFILES doesn't work either, because the necessary window messages are filtered out from the queue, but it is possible to configure the filters and make it work, see " { $link init-message-filter } "." ;
HELP: init-message-filter
{ $description "Call " { $snippet "ChangeWindowMessageFilter" } " to allow the window messages necessary for file dropping pass through the filters. This will have a process-wide effect, and will only be called once."
$nl
"The API function is only available since Windows Vista, and is not needed in earlier versions. On Windows XP the missing function will cause an exception on the first call, which will be suppressed, and no more calls will be made." }
{ $notes "It is generally preferrable to use " { $snippet "ChangeWindowMessageFilterEx" } ", because it has a per-window-handle effect, thus gives a more fine-grained security control. Unfortunately, the " { $snippet "Ex" } "-version is only available since Windows 7, and in any case the " { $link add-wm-handler } " has global effect for all Factor native windows, so it's not like we are exposing any additional code to potential exploitation." } ;
HELP: filecount-from-hdrop
{ $values
{ "hdrop" HDROP }
{ "n" number }
}
{ $description "Return the number of files in the drop." } ;
HELP: filenames-from-hdrop
{ $values
{ "hdrop" HDROP }
{ "filenames" array }
}
{ $description "Return an array of file names in the drop. Each file name is a string with a full path to a file or a folder." } ;

67
basis/windows/dropfiles/dropfiles.factor Normal file
View File

@ -0,0 +1,67 @@
! Copyright (C) 2017-2018 Alexander Ilin.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.data alien.libraries alien.strings
continuations fry init io.encodings.utf16n kernel literals math
namespaces sequences ui.backend.windows ui.gadgets.worlds
ui.gestures windows.errors windows.messages windows.shell32
windows.types windows.user32 ;
IN: windows.dropfiles
: filecount-from-hdrop ( hdrop -- n )
0xFFFFFFFF f 0 DragQueryFile ;
: filenames-from-hdrop ( hdrop -- filenames )
dup filecount-from-hdrop <iota>
[
2dup f 0 DragQueryFile 1 + ! get size of filename buffer
dup WCHAR <c-array>
[ swap DragQueryFile drop ] keep
utf16n alien>string
] with map ;
! : point-from-hdrop ( hdrop -- loc )
! POINT <struct> [ DragQueryPoint drop ] keep [ x>> ] [ y>> ] bi 2array ;
: handle-wm-dropfiles ( hdrop -- )
<alien> [ filenames-from-hdrop dropped-files set-global ] [ DragFinish ] bi
key-modifiers <file-drop> hand-gadget get-global propagate-gesture ;
! The ChangeWindowMessageFilter has a global per-process effect, and so is the
! list of wm-handlers. Therefore, there is no benefit in using the stricter
! ChangeWindowMessageFilterEx approach. Plus, the latter is not in Vista.
: (init-message-filter) ( -- )
"ChangeWindowMessageFilter" "user32" dlsym? [
${ WM_DROPFILES WM_COPYDATA WM_COPYGLOBALDATA }
[ MSGFLT_ADD ChangeWindowMessageFilter win32-error=0/f ] each
] when ;
: do-once ( guard-variable quot -- )
dupd '[ t _ set-global @ ] [ get-global ] dip unless ; inline
: init-message-filter ( -- )
\ init-message-filter [ (init-message-filter) ] do-once ;
: install-wm-handler ( -- )
[ drop 2nip handle-wm-dropfiles 0 ] WM_DROPFILES add-wm-handler ;
: hwnd-accept-files ( hwnd -- )
TRUE DragAcceptFiles init-message-filter install-wm-handler ;
: hwnd-reject-files ( hwnd -- )
FALSE DragAcceptFiles ;
: world-accept-files ( world -- )
handle>> hWnd>> hwnd-accept-files ;
: world-reject-files ( world -- )
handle>> hWnd>> hwnd-reject-files ;
: accept-files ( -- )
world get world-accept-files ;
: reject-files ( -- )
world get world-reject-files ;
[
f \ init-message-filter set-global
] "init-dropfiles" add-startup-hook

1
basis/windows/dropfiles/platforms.txt Normal file
View File

@ -0,0 +1 @@
windows

1
basis/windows/dropfiles/summary.txt Normal file
View File

@ -0,0 +1 @@
Implementation of the file-drop gesture for Windows

2
basis/windows/gdiplus/gdiplus.factor
View File

@ -248,7 +248,7 @@ ENUM: StringAlignment
{ StringAlignmentCenter 1 }
{ StringAlignmentFar 2 } ;
ENUM: StringDigitSubstitute
ENUM: StringDigitSubstitute
{ StringDigitSubstituteUser 0 }
{ StringDigitSubstituteNone 1 }
{ StringDigitSubstituteNational 2 }

2
basis/windows/kernel32/kernel32.factor
View File

@ -1861,7 +1861,7 @@ FUNCTION: DWORD SetFilePointerEx ( HANDLE hFile, LARGE_INTEGER lDistanceToMove,
! FUNCTION: SetFileShortNameA
! FUNCTION: SetFileShortNameW
FUNCTION: BOOL SetFileTime ( HANDLE hFile, FILETIME* lpCreationTime, FILETIME* lpLastAccessTime, FILETIME* lpLastWriteTime )
! FUNCTION: SetFileValidData
FUNCTION: BOOL SetFileValidData ( HANDLE hFile, LONGLONG ValidDataLength )
! FUNCTION: SetFirmwareEnvironmentVariableA
! FUNCTION: SetFirmwareEnvironmentVariableW
! FUNCTION: SetHandleContext

1
basis/windows/messages/messages.factor
View File

@ -69,6 +69,7 @@ CONSTANT: WM_COMMNOTIFY 0x0044
CONSTANT: WM_WINDOWPOSCHANGING 0x0046
CONSTANT: WM_WINDOWPOSCHANGED 0x0047
CONSTANT: WM_POWER 0x0048
CONSTANT: WM_COPYGLOBALDATA 0x0049
CONSTANT: WM_COPYDATA 0x004A
CONSTANT: WM_CANCELJOURNAL 0x004B
CONSTANT: WM_NOTIFY 0x004E

7
basis/windows/shell32/shell32.factor
View File

@ -231,7 +231,6 @@ STRUCT: DROPFILES
{ fWide BOOL } ;
TYPEDEF: DROPFILES* LPDROPFILES
TYPEDEF: DROPFILES* LPCDROPFILES
TYPEDEF: HANDLE HDROP
STRUCT: SHITEMID
{ cb USHORT }
@ -309,10 +308,16 @@ COM-INTERFACE: IShellFolder IUnknown {000214E6-0000-0000-C000-000000000046}
FUNCTION: HRESULT SHGetDesktopFolder ( IShellFolder** ppshf )
FUNCTION: void DragAcceptFiles ( HWND hWnd, BOOL fAccept )
FUNCTION: UINT DragQueryFileW ( HDROP hDrop,
UINT iFile,
LPWSTR lpszFile,
UINT cch )
ALIAS: DragQueryFile DragQueryFileW
FUNCTION: BOOL DragQueryPoint ( HDROP hDrop, POINT* lppt )
FUNCTION: void DragFinish ( HDROP hDrop )
FUNCTION: BOOL IsUserAnAdmin ( )

22
basis/windows/user32/user32.factor
View File

@ -1008,6 +1008,18 @@ STRUCT: DEVMODE
TYPEDEF: DEVMODE* PDEVMODE
TYPEDEF: DEVMODE* LPDEVMODE
CONSTANT: MSGFLT_ADD 1
CONSTANT: MSGFLT_REMOVE 2
CONSTANT: MSGFLT_RESET 0
CONSTANT: MSGFLT_ALLOW 1
CONSTANT: MSGFLT_DISALLOW 2
STRUCT: CHANGEFILTERSTRUCT
{ cbSize DWORD }
{ ExtStatus DWORD } ;
TYPEDEF: CHANGEFILTERSTRUCT* PCHANGEFILTERSTRUCT
LIBRARY: user32
FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags )
@ -1052,6 +1064,16 @@ ALIAS: ChangeDisplaySettingsEx ChangeDisplaySettingsExW
ALIAS: ChangeDisplaySettings ChangeDisplaySettingsW
! FUNCTION: ChangeMenuA
! FUNCTION: ChangeMenuW
FUNCTION: BOOL ChangeWindowMessageFilter (
UINT message,
DWORD dwFlag )
FUNCTION: BOOL ChangeWindowMessageFilterEx (
HWND hWnd,
UINT message,
DWORD action,
PCHANGEFILTERSTRUCT pChangeFilterStruct )
! FUNCTION: CharLowerA
! FUNCTION: CharLowerBuffA
! FUNCTION: CharLowerBuffW

2
core/alien/libraries/finder/linux/linux-tests.factor
View File

@ -1,5 +1,5 @@
USING: alien.libraries.finder sequences tools.test ;
IN: alien.libraries.fidner.linux
IN: alien.libraries.finder.linux.tests
{ t } [ "libm.so" "m" find-library subseq? ] unit-test
{ t } [ "libc.so" "c" find-library subseq? ] unit-test

9
core/alien/libraries/finder/linux/linux.factor
View File

@ -40,13 +40,8 @@ CONSTANT: mach-map {
: ldconfig-matches? ( lib triple -- ? )
{ [ name-matches? ] [ arch-matches? ] } 2&& ;
: ldconfig-find-soname ( lib -- seq )
load-ldconfig-cache [ ldconfig-matches? ] with filter
[ third ] map ;
PRIVATE>
M: linux find-library*
"lib" prepend ldconfig-find-soname [
{ [ exists? ] [ file-info regular-file? ] } 1&&
] find nip ;
"lib" prepend load-ldconfig-cache
[ ldconfig-matches? ] with find nip ?first ;

2
core/checksums/checksums-docs.factor
View File

@ -41,7 +41,7 @@ HELP: checksum-file
{ $example
"USING: checksums checksums.crc32 prettyprint ;"
"\"resource:LICENSE.txt\" crc32 checksum-file ."
"B{ 47 65 106 90 }"
"B{ 125 29 106 28 }"
}
} ;

2
core/locals/types/types-tests.factor
View File

@ -1,5 +1,5 @@
USING: accessors compiler.units kernel locals.types tools.test words ;
IN: locals.types.test
IN: locals.types.tests
{ t } [
[ "hello" <local> ] with-compilation-unit "local?" word-prop

2
core/sequences/sequences-docs.factor
View File

@ -1343,7 +1343,7 @@ HELP: sift
{ $values
{ "seq" sequence }
{ "newseq" sequence } }
{ $description "Outputs a new sequence with all instance of " { $link f } " removed." }
{ $description "Outputs a new sequence with all instances of " { $link f } " removed." }
{ $examples
{ $example "USING: prettyprint sequences ;"
"{ \"a\" 3 { } f } sift ."

10
core/sorting/sorting.factor
View File

@ -41,20 +41,18 @@ TUPLE: merge-state
push-all-unsafe ; inline
: l-next ( merge -- )
[ [ l-elt ] [ [ 1 + ] change-from1 drop ] bi ] [ accum>> ] bi
push-unsafe ; inline
[ l-elt ] [ [ 1 + ] change-from1 accum>> ] bi push-unsafe ; inline
: r-next ( merge -- )
[ [ r-elt ] [ [ 1 + ] change-from2 drop ] bi ] [ accum>> ] bi
push-unsafe ; inline
[ r-elt ] [ [ 1 + ] change-from2 accum>> ] bi push-unsafe ; inline
: decide ( merge quot: ( elt1 elt2 -- <=> ) -- ? )
: decide? ( merge quot: ( elt1 elt2 -- <=> ) -- ? )
[ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
: (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- )
over r-done? [ drop dump-l ] [
over l-done? [ drop dump-r ] [
2dup decide
2dup decide?
[ over r-next ] [ over l-next ] if
(merge)
] if

2
core/stack-checker/values/values.factor
View File

@ -122,7 +122,7 @@ M: f (literal) current-word get bad-macro-input ;
GENERIC: known>callable ( known -- quot )
: ?@ ( x -- y )
dup callable? [ drop [ @ ] ] unless ;
dup callable? [ drop _ ] unless ;
M: object known>callable drop \ _ ;

8
core/syntax/syntax-docs.factor
View File

@ -671,16 +671,16 @@ HELP: \nan:
HELP: \GENERIC:
{ $syntax "GENERIC: word ( stack -- effect )" }
{ $values { "word" "a new word to define" } }
{ $description "Defines a new generic word in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } ;
{ $description "Defines a new generic word in the current vocabulary. The word dispatches on the topmost stack element. Initially it contains no methods, and thus will throw a " { $link no-method } " error when called." } ;
HELP: \GENERIC#:
{ $syntax "GENERIC#: word n ( stack -- effect )" }
{ $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } }
{ $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." }
{ $description "Defines a new generic word in the current vocabulary. The word dispatches on the " { $snippet "n" } "th element from the top of the stack. Initially it contains no methods, and thus will throw a " { $link no-method } " error when called." }
{ $notes
"The following two definitions are equivalent:"
{ $code "GENERIC: foo ( obj -- )" }
{ $code "GENERIC#: foo 0 ( obj -- )" }
{ $code "GENERIC: foo ( x y z obj -- )" }
{ $code "GENERIC#: foo 0 ( x y z obj -- )" }
} ;
HELP: \MATH:

2
core/vocabs/vocabs.factor
View File

@ -45,7 +45,7 @@ GENERIC: lookup-vocab ( vocab-spec -- vocab )
M: vocab lookup-vocab ;
M: object lookup-vocab ( name -- vocab ) vocab-name dictionary get at ;
M: object lookup-vocab vocab-name dictionary get at ;
GENERIC: vocab-words-assoc ( vocab-spec -- assoc/f )

46
extra/boids/boids.factor
View File

@ -2,12 +2,13 @@
! Copyright (C) 2011 Anton Gorenko.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays boids.simulation calendar classes
colors.constants combinators.smart.syntax kernel locals math
math.functions math.trig models opengl opengl.gl
processing.shapes sequences threads ui ui.gadgets
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.frames
ui.gadgets.grids ui.gadgets.labeled ui.gadgets.labels
ui.gadgets.packs ui.gadgets.sliders ui.render ui.tools.common ;
colors.constants kernel literals locals math math.functions
math.trig models namespaces opengl opengl.demo-support opengl.gl
sequences threads ui ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.buttons ui.gadgets.frames ui.gadgets.grids
ui.gadgets.labeled ui.gadgets.labels ui.gadgets.packs
ui.gadgets.sliders ui.gadgets.tracks ui.gadgets.worlds ui.render
ui.tools.common ;
QUALIFIED-WITH: models.range mr
IN: boids
@ -30,7 +31,7 @@ CONSTANT: initial-dt 5
initial-behaviours >>behaviours
initial-dt >>dt ;
M: boids-gadget ungraft*
M: boids-gadget ungraft*
t >>paused drop ;
: vec>deg ( vec -- deg )
@ -104,12 +105,19 @@ M: range-observer model-changed
[ neg random-boids append ] if
] change-boids drop ;
: pause-toggle ( boids-gadget -- )
<PRIVATE
: find-boids-gadget ( gadget -- boids-gadget )
dup boids-gadget? [ children>> [ boids-gadget? ] find nip ] unless ;
PRIVATE>
: com-pause ( boids-gadget -- )
find-boids-gadget
dup paused>> not [ >>paused ] keep
[ drop ] [ start-boids-thread ] if ;
: randomize-boids ( boids-gadget -- )
[ length random-boids ] change-boids drop ;
: com-randomize ( boids-gadget -- )
find-boids-gadget
[ length random-boids ] change-boids relayout-1 ;
:: simulation-panel ( boids-gadget -- gadget )
<pile> white-interior
@ -129,17 +137,19 @@ M: range-observer model-changed
{ 5 5 } <border> add-gadget
<shelf> { 2 2 } >>gap
"pause" [ drop boids-gadget pause-toggle ]
"pause" [ drop boids-gadget com-pause ]
<border-button> add-gadget
"randomize" [ drop boids-gadget randomize-boids ]
"randomize" [ drop boids-gadget com-randomize ]
<border-button> add-gadget
{ 5 5 } <border> add-gadget
"simulation" color: gray <framed-labeled-gadget> ;
:: create-gadgets ( -- gadgets )
<shelf>
TUPLE: boids-frame < pack ;
:: <boids-frame> ( -- boids-frame )
boids-frame new horizontal >>orientation
<boids-gadget> :> boids-gadget
boids-gadget [ start-boids-thread ] keep
add-gadget
@ -154,6 +164,10 @@ M: range-observer model-changed
{ 5 5 } <border> add-gadget ;
boids-frame "touchbar" f {
{ f com-pause }
{ f com-randomize }
} define-command-map
MAIN-WINDOW: boids { { title "Boids" } }
create-gadgets
>>gadgets ;
<boids-frame> >>gadgets ;

16
extra/boids/deploy.factor Normal file
View File

@ -0,0 +1,16 @@
USING: tools.deploy.config ;
H{
{ deploy-console? f }
{ deploy-io 3 }
{ deploy-reflection 2 }
{ deploy-ui? t }
{ deploy-word-defs? f }
{ deploy-threads? t }
{ "stop-after-last-window?" t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-help? f }
{ deploy-name "Boids" }
{ deploy-unicode? f }
}

1
extra/boolean-expr/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

128
extra/boolean-expr/boolean-expr-docs.factor Normal file
View File

@ -0,0 +1,128 @@
! Copyright (C) 2018 Alexander Ilin.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays help.markup help.syntax kernel quotations sequences ;
IN: boolean-expr
ABOUT: "boolean-expr"
ARTICLE: "boolean-expr" "Boolean expressions"
"The " { $vocab-link "boolean-expr" } " vocab demonstrates the use of Unicode symbols in source files and multi-method dispatch."
;
HELP: dnf
{ $values
{ "expr" □ }
{ "dnf" array }
}
{ $description "Convert the " { $snippet "expr" } " to Disjunctive Normal Form (DNF), i.e. an array of subexpressions, each not containing disjunctions. See " { $url "https://en.wikipedia.org/wiki/Disjunctive_normal_form" } "." }
{ $examples
{ $example "USING: boolean-expr prettyprint ;"
"X Y Z ⋀ ⋀ dnf ."
"{ { X Y Z } }"
}
{ $example "USING: boolean-expr prettyprint ;"
"X Y Z ⋁ ⋁ dnf ."
"{ { X } { Y } { Z } }"
}
} ;
HELP: expr.
{ $values
{ "expr" □ }
}
{ $description "Print the expression followed by newline." }
{ $examples
{ $example "USING: boolean-expr ;"
"X Y ⋁ X ¬ Y ⋀ ⋀ op."
"((X ⋀ (¬X ⋀ Y)) ⋁ (Y ⋀ (¬X ⋀ Y)))"
}
} ;
HELP: op.
{ $values
{ "expr" □ }
}
{ $description "Print the expression." }
{ $examples
{ $example "USING: boolean-expr ;"
"X Y ⋁ X ¬ Y ⋀ ⋀ op."
"((X ⋀ (¬X ⋀ Y)) ⋁ (Y ⋀ (¬X ⋀ Y)))"
}
} ;
{ expr. op. } related-words
HELP: satisfiable?
{ $values
{ "expr" □ }
{ "?" boolean }
}
{ $description "Return " { $link t } " if the " { $snippet "expr" } " can be true." }
{ $examples
{ $example "USING: boolean-expr prettyprint ;"
"⊤ satisfiable? ."
"t"
}
{ $example "USING: boolean-expr prettyprint ;"
"⊥ satisfiable? ."
"f"
}
{ $example "USING: boolean-expr prettyprint ;"
"X X ¬ ⋀ satisfiable? ."
"f"
}
{ $example "USING: boolean-expr prettyprint ;"
"X Y ⋁ X ¬ Y ¬ ⋀ ⋀ satisfiable? ."
"f"
}
{ $example "USING: boolean-expr prettyprint ;"
"X Y ⋁ X ¬ Y ⋀ ⋀ satisfiable? ."
"t"
}
} ;
HELP: ¬
{ $class-description "Logical negation (NOT)." $nl
{ $snippet "¬(¬A) " { $link ≣ } " A" } "."
} ;
HELP: →
{ $values
{ "x" □ } { "y" □ }
{ "expr" □ }
}
{ $description "Material implication (if..then)." $nl
{ $snippet "x→y" } " " { $link ≣ } " " { $link ¬ } "x" { $link ⋁ } "y"
} ;
HELP: ≣
{ $values
{ "x" □ } { "y" □ }
{ "expr" □ }
}
{ $description "Material equivalence (if and only if)." $nl
{ $snippet "(x≣y) ≣ ((x" } { $link ⋀ } { $snippet "y) " }
{ $link ⋁ } { $snippet " (" } { $link ¬ } { $snippet "x" } { $link ⋀ } { $link ¬ } { $snippet "y))" }
} ;
HELP: ⊕
{ $values
{ "x" □ } { "y" □ }
{ "expr" □ }
}
{ $description "Exclusive disjunction (XOR)." } ;
HELP: ⊤
{ $class-description "Logical tautology. This statement is unconditionally true." } ;
HELP: ⊥
{ $class-description "Logical contradiction. This statement is unconditionally false." } ;
HELP: ⋀
{ $class-description "Logical conjuction (AND)." } ;
HELP: ⋁
{ $class-description "Logical disjunction (OR)." } ;
HELP: □
{ $class-description "A union class of all classes defined in this vocab. In methods signatures it stands for \"any variable or expression\"." } ;

91
extra/boolean-expr/boolean-expr.factor Normal file
View File

@ -0,0 +1,91 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes kernel sequences sets
io prettyprint ;
FROM: multi-methods => GENERIC: METHOD: ;
IN: boolean-expr
TUPLE: ⋀ x y ;
TUPLE: ⋁ x y ;
TUPLE: ¬ x ;
SINGLETONS: ⊤ ⊥ ;
SINGLETONS: P Q R S T U V W X Y Z ;
UNION: □ ⋀ ⋁ ¬ ⊤ ⊥ P Q R S T U V W X Y Z ;
GENERIC: ⋀ ( x y -- expr )
METHOD: ⋀ { ⊤ □ } nip ;
METHOD: ⋀ { □ ⊤ } drop ;
METHOD: ⋀ { ⊥ □ } drop ;
METHOD: ⋀ { □ ⊥ } nip ;
METHOD: ⋀ { ⋁ □ } [ [ x>> ] dip ⋀ ] [ [ y>> ] dip ⋀ ] 2bi ⋁ ;
METHOD: ⋀ { □ ⋁ } [ x>> ⋀ ] [ y>> ⋀ ] 2bi ⋁ ;
METHOD: ⋀ { □ □ } \ ⋀ boa ;
GENERIC: ⋁ ( x y -- expr )
METHOD: ⋁ { ⊤ □ } drop ;
METHOD: ⋁ { □ ⊤ } nip ;
METHOD: ⋁ { ⊥ □ } nip ;
METHOD: ⋁ { □ ⊥ } drop ;
METHOD: ⋁ { □ □ } \ ⋁ boa ;
GENERIC: ¬ ( x -- expr )
METHOD: ¬ { ⊤ } drop ⊥ ;
METHOD: ¬ { ⊥ } drop ⊤ ;
METHOD: ¬ { ⋀ } [ x>> ¬ ] [ y>> ¬ ] bi ⋁ ;
METHOD: ¬ { ⋁ } [ x>> ¬ ] [ y>> ¬ ] bi ⋀ ;
METHOD: ¬ { □ } \ ¬ boa ;
: → ( x y -- expr ) ¬ ⋀ ;
: ⊕ ( x y -- expr ) [ ⋁ ] [ ⋀ ¬ ] 2bi ⋀ ;
: ≣ ( x y -- expr ) [ ⋀ ] [ [ ¬ ] bi@ ⋀ ] 2bi ⋁ ;
GENERIC: (dnf) ( expr -- dnf )
METHOD: (dnf) { ⋀ } [ x>> (dnf) ] [ y>> (dnf) ] bi append ;
METHOD: (dnf) { □ } 1array ;
GENERIC: dnf ( expr -- dnf )
METHOD: dnf { ⋁ } [ x>> dnf ] [ y>> dnf ] bi append ;
METHOD: dnf { □ } (dnf) 1array ;
GENERIC: satisfiable? ( expr -- ? )
METHOD: satisfiable? { ⊤ } drop t ;
METHOD: satisfiable? { ⊥ } drop f ;
! See if there is a term along with its negation in the conjunction seq.
: (satisfiable?) ( seq -- ? )
[ ¬? ] partition swap [ x>> ] map intersect empty? ;
METHOD: satisfiable? { □ }
dnf [ (satisfiable?) ] any? ;
GENERIC: (expr.) ( expr -- )
METHOD: (expr.) { □ } pprint ;
: op. ( expr -- )
"(" write
[ x>> (expr.) ]
[ bl class-of pprint bl ]
[ y>> (expr.) ]
tri
")" write ;
METHOD: (expr.) { ⋀ } op. ;
METHOD: (expr.) { ⋁ } op. ;
METHOD: (expr.) { ¬ } [ class-of pprint ] [ x>> (expr.) ] bi ;
: expr. ( expr -- ) (expr.) nl ;

1
extra/boolean-expr/summary.txt Normal file
View File

@ -0,0 +1 @@
Simple boolean expression evaluator and simplifier

4
extra/bson/writer/writer.factor
View File

@ -13,8 +13,6 @@ IN: bson.writer
CONSTANT: INT32-SIZE 4
CONSTANT: INT64-SIZE 8
PRIVATE>
TYPED: get-output ( -- stream: byte-vector )
output-stream get ; inline
@ -32,8 +30,6 @@ TYPED: with-length ( quot -- bytes-written: integer start-index: integer )
: with-length-prefix-excl ( quot: ( .. -- .. ) -- )
[ 4 - ] (with-length-prefix) ; inline
<PRIVATE
: write-le ( x n -- )
<iota> [ nth-byte write1 ] with each ; inline

500
extra/bubble-chamber/bubble-chamber.factor Normal file
View File

@ -0,0 +1,500 @@
USING: accessors arrays ascii calendar colors colors.gray
combinators.short-circuit fry kernel locals math math.constants
math.functions math.libm math.order math.points math.ranges
math.vectors namespaces opengl processing.shapes quotations
random sequences splitting threads timers ui ui.gadgets
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.frame-buffer
ui.gadgets.packs ui.gestures ;
IN: bubble-chamber
! This is a Factor implementation of an art piece by Jared Tarbell:
!
! http://complexification.net/gallery/machines/bubblechamber/
!
! Jared's version is written in Processing (Java)
: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
: 1random ( b -- num ) 0 swap 2random ;
: at-fraction ( seq fraction -- val ) over length 1 - * >integer swap nth ;
: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
: mouse ( -- point ) hand-loc get ;
: mouse-x ( -- x ) mouse first ;
: mouse-y ( -- y ) mouse second ;
: draw ( point -- )
gl-scale-factor get-global [
stroke-color get fill-color set
>integer draw-circle
] [
draw-point
] if* ;
GENERIC: collide ( particle -- )
GENERIC: move ( particle -- )
TUPLE: particle
bubble-chamber pos vel speed speed-d theta theta-d theta-dd myc mya ;
: initialize-particle ( particle -- particle )
{ 0 0 } >>pos
{ 0 0 } >>vel
0 >>speed
0 >>speed-d
0 >>theta
0 >>theta-d
0 >>theta-dd
0 0 0 1 rgba boa >>myc
0 0 0 1 rgba boa >>mya ;
: center ( particle -- point ) bubble-chamber>> size>> 2 v/n ;
DEFER: collision-theta
: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
: theta-dd-small? ( par limit -- par ? ) [ dup theta-dd>> abs ] dip < ;
: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
: turn ( particle -- particle )
dup
[ speed>> ] [ theta>> [ sin ] [ cos ] bi 2array ] bi n*v
>>vel ;
: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
:: out-of-bounds? ( PARTICLE -- ? )
PARTICLE pos>> first :> X
PARTICLE pos>> second :> Y
PARTICLE bubble-chamber>> size>> first :> WIDTH
PARTICLE bubble-chamber>> size>> second :> HEIGHT
WIDTH neg :> LEFT
WIDTH 2 * :> RIGHT
HEIGHT neg :> BOTTOM
HEIGHT 2 * :> TOP
{ [ X LEFT < ] [ X RIGHT > ] [ Y BOTTOM < ] [ Y TOP > ] } 0|| ;
TUPLE: axion < particle ;
: <axion> ( -- axion ) axion new initialize-particle ;
M: axion collide
dup center >>pos
2 pi * 1random >>theta
1.0 6.0 2random >>speed
0.998 1.000 2random >>speed-d
0 >>theta-d
0 >>theta-dd
[ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
drop ;
: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
! : axion-white ( dy -- dy ) dup 1 swap dy>alpha 2array stroke-color set ;
! : axion-black ( dy -- dy ) dup 0 swap dy>alpha 2array stroke-color set ;
: axion-white ( dy -- dy ) dup 1 swap dy>alpha gray boa stroke-color set ;
: axion-black ( dy -- dy ) dup 0 swap dy>alpha gray boa stroke-color set ;
: axion-point- ( particle dy -- particle ) [ dup pos>> ] dip v-y draw ;
: axion-point+ ( particle dy -- particle ) [ dup pos>> ] dip v+y draw ;
M: axion move
T{ gray f 0.06 0.59 } stroke-color set
dup pos>> draw
1 4 [a,b] [ axion-white axion-point- ] each
1 4 [a,b] [ axion-black axion-point+ ] each
dup vel>> move-by
turn
step-theta
step-theta-d
step-speed-mul
[ ] [ speed-d>> 0.9999 * ] bi >>speed-d
1000 random 996 >
[
dup speed>> neg >>speed
dup speed-d>> neg 2 + >>speed-d
100 random 30 > [ collide ] [ drop ] if
]
[ drop ]
if ;
TUPLE: hadron < particle ;
: <hadron> ( -- hadron ) hadron new initialize-particle ;
M: hadron collide
dup center >>pos
2 pi * 1random >>theta
0.5 3.5 2random >>speed
0.996 1.001 2random >>speed-d
0 >>theta-d
0 >>theta-dd
[ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
0 1 0 1 rgba boa >>myc
drop ;
M: hadron move
T{ gray f 1 0.11 } stroke-color set dup pos>> 1 v-y draw
T{ gray f 0 0.11 } stroke-color set dup pos>> 1 v+y draw
dup vel>> move-by
turn
step-theta
step-theta-d
step-speed-mul
1000 random 997 >
[
1.0 >>speed-d
0.00001 >>theta-dd
100 random 70 > [ dup collide ] when
]
when
dup out-of-bounds? [ collide ] [ drop ] if ;
CONSTANT: good-colors {
T{ rgba f 0.23 0.14 0.17 1 }
T{ rgba f 0.23 0.14 0.15 1 }
T{ rgba f 0.21 0.14 0.15 1 }
T{ rgba f 0.51 0.39 0.33 1 }
T{ rgba f 0.49 0.33 0.20 1 }
T{ rgba f 0.55 0.45 0.32 1 }
T{ rgba f 0.69 0.63 0.51 1 }
T{ rgba f 0.64 0.39 0.18 1 }
T{ rgba f 0.73 0.42 0.20 1 }
T{ rgba f 0.71 0.45 0.29 1 }
T{ rgba f 0.79 0.45 0.22 1 }
T{ rgba f 0.82 0.56 0.34 1 }
T{ rgba f 0.88 0.72 0.49 1 }
T{ rgba f 0.85 0.69 0.40 1 }
T{ rgba f 0.96 0.92 0.75 1 }
T{ rgba f 0.99 0.98 0.87 1 }
T{ rgba f 0.85 0.82 0.69 1 }
T{ rgba f 0.99 0.98 0.87 1 }
T{ rgba f 0.82 0.82 0.79 1 }
T{ rgba f 0.65 0.69 0.67 1 }
T{ rgba f 0.53 0.60 0.55 1 }
T{ rgba f 0.57 0.53 0.68 1 }
T{ rgba f 0.47 0.42 0.56 1 }
}
: anti-colors ( -- seq ) good-colors <reversed> ;
: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
: set-good-color ( particle -- particle )
color-fraction dup 0 1 between?
[ good-colors at-fraction-of >>myc ] [ drop ] if ;
: set-anti-color ( particle -- particle )
color-fraction dup 0 1 between?
[ anti-colors at-fraction-of >>mya ] [ drop ] if ;
TUPLE: muon < particle ;
: <muon> ( -- muon ) muon new initialize-particle ;
M: muon collide
dup center >>pos
2 32 [a,b] random >>speed
0.0001 0.001 2random >>speed-d
dup collision-theta -0.1 0.1 2random + >>theta
0 >>theta-d
0 >>theta-dd
[ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] while
set-good-color
set-anti-color
drop ;
M:: muon move ( MUON -- )
MUON bubble-chamber>> size>> first :> WIDTH
MUON
dup myc>> >rgba-components drop 0.16 <rgba> stroke-color set
dup pos>> draw
dup mya>> >rgba-components drop 0.16 <rgba> stroke-color set
dup pos>> first2 [ WIDTH swap - ] dip 2array draw
dup
[ speed>> ] [ theta>> [ sin ] [ cos ] bi 2array ] bi n*v
move-by
step-theta
step-theta-d
step-speed-sub
dup out-of-bounds? [ collide ] [ drop ] if ;
TUPLE: quark < particle ;
: <quark> ( -- quark ) quark new initialize-particle ;
M: quark collide
dup center >>pos
dup collision-theta -0.11 0.11 2random + >>theta
0.5 3.0 2random >>speed
0.996 1.001 2random >>speed-d
0 >>theta-d
0 >>theta-dd
[ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
drop ;
M:: quark move ( QUARK -- )
QUARK bubble-chamber>> size>> first :> WIDTH
QUARK
dup myc>> >rgba-components drop 0.13 <rgba> stroke-color set
dup pos>> draw
dup pos>> first2 [ WIDTH swap - ] dip 2array draw
[ ] [ vel>> ] bi move-by
turn
step-theta
step-theta-d
step-speed-mul
1000 random 997 > [
dup speed>> neg >>speed
2 over speed-d>> - >>speed-d
] when
dup out-of-bounds? [ collide ] [ drop ] if ;
TUPLE: bubble-chamber < frame-buffer
particles collision-theta size timer ;
M: bubble-chamber graft*
[ timer>> start-timer yield ] [ call-next-method ] bi ;
M: bubble-chamber ungraft*
[ timer>> stop-timer ] [ call-next-method ] bi ;
! : randomize-collision-theta ( bubble-chamber -- bubble-chamber )
! 0 2 pi * 0.001 <range> random >>collision-theta ;
: randomize-collision-theta ( bubble-chamber -- bubble-chamber )
pi neg pi 0.001 <range> random >>collision-theta ;
: collision-theta ( particle -- theta ) bubble-chamber>> collision-theta>> ;
M: bubble-chamber pref-dim* ( gadget -- dim ) size>> ;
: iterate-particle ( particle -- ) move ;
M:: bubble-chamber update-frame-buffer ( BUBBLE-CHAMBER -- )
BUBBLE-CHAMBER particles>> [ iterate-particle ] each ;
: iterate-system ( bubble-chamber -- ) drop ;
: <bubble-chamber> ( -- bubble-chamber )
bubble-chamber new
{ 1000 1000 } >>size
randomize-collision-theta
dup '[ _ dup iterate-system relayout-1 ]
f 10 milliseconds <timer> >>timer ;
: bubble-chamber-window ( -- bubble-chamber )
<bubble-chamber> dup "Bubble Chamber" open-window ;
:: add-particle ( BUBBLE-CHAMBER PARTICLE -- bubble-chamber )
PARTICLE BUBBLE-CHAMBER >>bubble-chamber drop
BUBBLE-CHAMBER [ PARTICLE suffix ] change-particles ;
:: mouse->collision-theta ( BUBBLE-CHAMBER -- BUBBLE-CHAMBER )
mouse
BUBBLE-CHAMBER size>> 2 v/n
v-
first2
fatan2
BUBBLE-CHAMBER collision-theta<<
BUBBLE-CHAMBER ;
:: mouse-pressed ( BUBBLE-CHAMBER -- )
BUBBLE-CHAMBER mouse->collision-theta drop
11 [
BUBBLE-CHAMBER particles>> [ hadron? ] filter random [ collide ] when*
BUBBLE-CHAMBER particles>> [ quark? ] filter random [ collide ] when*
BUBBLE-CHAMBER particles>> [ muon? ] filter random [ collide ] when*
] times ;
bubble-chamber H{
{ T{ button-down } [ mouse-pressed ] }
} set-gestures
: collide-random-particle ( bubble-chamber -- bubble-chamber )
dup particles>> random collide ;
: big-bang ( bubble-chamber -- bubble-chamber )
dup particles>> [ collide ] each ;
: collide-one-of-each ( bubble-chamber -- bubble-chamber )
dup
particles>>
[ [ muon? ] filter random collide ]
[ [ quark? ] filter random collide ]
[ [ hadron? ] filter random collide ]
tri ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ten-hadrons ( -- )
bubble-chamber-window
10 [ <hadron> add-particle ] times
drop ;
: original ( -- )
bubble-chamber-window
1789 [ <muon> add-particle ] times
1300 [ <quark> add-particle ] times
1000 [ <hadron> add-particle ] times
111 [ <axion> add-particle ] times
particles>>
[ [ muon? ] filter random collide ]
[ [ quark? ] filter random collide ]
[ [ hadron? ] filter random collide ]
tri ;
: hadron-chamber ( -- )
bubble-chamber-window
1000 [ <hadron> add-particle ] times
big-bang
drop ;
: quark-chamber ( -- )
bubble-chamber-window
100 [ <quark> add-particle ] times
big-bang
drop ;
: small ( -- )
<bubble-chamber>
{ 200 200 } >>size
dup "Bubble Chamber" open-window
42 [ <muon> add-particle ] times
30 [ <quark> add-particle ] times
21 [ <hadron> add-particle ] times
7 [ <axion> add-particle ] times
collide-one-of-each
drop ;
: medium ( -- )
<bubble-chamber>
{ 400 400 } >>size
dup "Bubble Chamber" open-window
100 [ <muon> add-particle ] times
81 [ <quark> add-particle ] times
60 [ <hadron> add-particle ] times
9 [ <axion> add-particle ] times
collide-one-of-each
drop ;
: large ( -- )
<bubble-chamber>
{ 600 600 } >>size
dup "Bubble Chamber" open-window
550 [ <muon> add-particle ] times
339 [ <quark> add-particle ] times
100 [ <hadron> add-particle ] times
11 [ <axion> add-particle ] times
collide-one-of-each
drop ;
: muon-chamber ( -- )
bubble-chamber-window
1000 [ <muon> add-particle ] times
dup particles>> [ collide randomize-collision-theta ] each
drop ;
: original-big-bang ( -- )
<bubble-chamber>
{ 1000 1000 } >>size
dup "Bubble Chamber" open-window
1789 [ <muon> add-particle ] times
1300 [ <quark> add-particle ] times
1000 [ <hadron> add-particle ] times
111 [ <axion> add-particle ] times
big-bang
drop ;
: original-big-bang-variant ( -- )
bubble-chamber-window
1789 [ <muon> add-particle ] times
1300 [ <quark> add-particle ] times
1000 [ <hadron> add-particle ] times
111 [ <axion> add-particle ] times
dup particles>> [ collide randomize-collision-theta ] each
drop ;
MAIN-WINDOW: run-bubble-chamber { { title "Bubble Chamber" } }
<filled-pile> { 2 2 } >>gap {
original small medium large hadron-chamber
quark-chamber muon-chamber ten-hadrons
original-big-bang original-big-bang-variant
} [
[ name>> "-" " " replace >title ]
[ 1quotation [ drop ] prepend ] bi
<border-button> add-gadget
] each { 2 2 } <border> >>gadgets ;

1
extra/bubble-chamber/tags.txt Normal file
View File

@ -0,0 +1 @@
demos

2
extra/calendar/elapsed/elapsed-tests.factor
View File

@ -3,7 +3,7 @@
USING: calendar calendar.elapsed kernel tools.test ;
IN: calendar.elapsed.test
IN: calendar.elapsed.tests
[ -1 elapsed-time ] [ "negative seconds" = ] must-fail-with

2
extra/cap/cap.factor
View File

@ -12,7 +12,7 @@ IN: cap
[ gl-scale ] bi@ * >fixnum <byte-array> ;
: gl-screenshot ( gadget -- byte-array )
[ find-world handle>> select-gl-context ]
[ find-gl-context ]
[
[
GL_BACK glReadBuffer

2
extra/changer/changer.factor
View File

@ -6,6 +6,6 @@ IN: changer
MACRO: inline-changer ( name -- quot' )
[ ">>" append ] [ ">>" prepend ] bi
[ "accessors" lookup-word 1quotation ] bi@
'[ over [ [ @ ] dip call ] dip swap @ ] ;
'[ over [ _ dip call ] dip swap @ ] ;
SYNTAX: \change: scan-token '[ _ inline-changer ] append! ;

1
extra/checksums/sodium/authors.txt Normal file
View File

@ -0,0 +1 @@
Alexander Ilin

21
extra/checksums/sodium/sodium-tests.factor Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2018 Alexander Ilin.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test checksums checksums.sodium ;
IN: checksums.sodium.tests
CONSTANT: test-lines { "Hello," "world!" }
CONSTANT: key B{ 1 2 3 4 5 }
{ B{
139 36 186 84 68 114 23 158 49 88 99 135 7 27 173 126 1 166
211 245 212 87 23 116 86 191 32 15 106 139 134 168 184 156
246 65 84 90 77 78 127 26 18 229 103 211 131 111 224 131 48
77 157 208 10 231 152 223 132 200 228 141 25 64
} } [ test-lines 64 f <sodium-checksum> checksum-lines ] unit-test
{ B{
51 107 65 253 93 78 146 11 36 184 39 107 133 237 22 60 249
171 78 26 189 168 126 117 78 134 62 73 166 1 208 132 76 197
54 33 174 82 148 192 158 211 190 77 104 154 39 187 128 118
216 161 100 21 241 244 199 135 79 62 233 12 137 185
} } [ test-lines 64 key <sodium-checksum> checksum-lines ] unit-test

45
extra/checksums/sodium/sodium.factor Normal file
View File

@ -0,0 +1,45 @@
! Copyright (C) 2017 Alexander Ilin.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien byte-arrays checksums checksums.common
destructors kernel math sequences sodium sodium.ffi ;
IN: checksums.sodium
TUPLE: sodium-checksum
{ output-size fixnum }
{ key maybe{ byte-array } } ;
INSTANCE: sodium-checksum block-checksum
C: <sodium-checksum> sodium-checksum
<PRIVATE
TUPLE: sodium-state < disposable
{ state alien }
{ output-size fixnum }
{ output maybe{ byte-array } } ;
PRIVATE>
M: sodium-checksum initialize-checksum-state
[ key>> ] [ output-size>> ] bi
sodium-state new-disposable swap >>output-size
crypto_generichash_statebytes sodium_malloc >>state
[
[ state>> ] [ drop swap dup length ] [ output-size>> ] tri
crypto_generichash_init check0
] keep ;
M: sodium-state dispose*
state>> [ sodium_free ] when* ;
M: sodium-state add-checksum-bytes
[ dup state>> ] dip dup length crypto_generichash_update check0 ;
M: sodium-state get-checksum
dup output>> [
dup state>> [
over output-size>> [ <byte-array> ] keep
[ crypto_generichash_final check0 ] 2keep drop
] [ B{ } clone ] if*
[ >>output ] keep
] unless* nip ;

1
extra/checksums/sodium/summary.txt Normal file
View File

@ -0,0 +1 @@
The default hash implementation provided by the Sodium crypto library

2
extra/checksums/sodium/tags.txt Normal file
View File

@ -0,0 +1,2 @@
not loaded
not tested

2
extra/demos/demos.factor
View File

@ -9,7 +9,7 @@ IN: demos
dup '[ drop [ _ run ] \ run call-listener ] <border-button> ;
: <demo-runner> ( -- gadget )
<pile> 1 >>fill { 2 2 } >>gap demo-vocabs [ <run-vocab-button> add-gadget ] each ;
<filled-pile> { 2 2 } >>gap demo-vocabs [ <run-vocab-button> add-gadget ] each ;
MAIN-WINDOW: demos { { title "Demos" } }
<demo-runner> { 2 2 } <border> <scroller> >>gadgets ;

12
extra/fuel/fuel-tests.factor
View File

@ -14,18 +14,18 @@ IN: fuel.tests
"Defer word in current vocabulary" f
fake-continuation <restart> ;
{ f } [ make-defer-restart is-use-restart ] unit-test
{ t } [ make-uses-restart is-use-restart ] unit-test
{ f } [ make-defer-restart is-use-restart? ] unit-test
{ t } [ make-uses-restart is-use-restart? ] unit-test
{ "words" } [ make-uses-restart get-restart-vocab ] unit-test
{ f } [ make-defer-restart is-suggested-restart ] unit-test
{ f } [ make-uses-restart is-suggested-restart ] unit-test
{ f } [ make-defer-restart is-suggested-restart? ] unit-test
{ f } [ make-uses-restart is-suggested-restart? ] unit-test
{ f } [ { "io" } :uses-suggestions
[ make-uses-restart is-suggested-restart ] with-variable
[ make-uses-restart is-suggested-restart? ] with-variable
] unit-test
{ t } [ { "words" } :uses-suggestions
[ make-uses-restart is-suggested-restart ] with-variable
[ make-uses-restart is-suggested-restart? ] with-variable
] unit-test
{ } [

Some files were not shown because too many files have changed in this diff Show More