Merge commit 'erg/master'

db4
Slava Pestov 2008-01-14 19:12:24 -05:00
commit 02fc6cdaed
58 changed files with 265 additions and 157 deletions

View File

@ -0,0 +1,7 @@
USING: crypto.sha1 io.files kernel ;
IN: benchmark.sha1
: sha1-primes-list ( -- seq )
"extra/math/primes/list/list.factor" resource-path file>sha1 ;
MAIN: sha1-primes-list

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup channels ; USING: help.syntax help.markup ;
IN: channels IN: channels
HELP: <channel> HELP: <channel>

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup channels channels.remote concurrency.distributed ; USING: help.syntax help.markup channels concurrency.distributed ;
IN: channels.remote IN: channels.remote
HELP: <remote-channel> HELP: <remote-channel>

View File

@ -0,0 +1,3 @@
USING: io.backend ;
HOOK: sniff-channel io-backend ( -- channel )

View File

@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! !
! Wrap a sniffer in a channel ! Wrap a sniffer in a channel
USING: kernel channels channels.sniffer concurrency io USING: kernel channels channels.sniffer.backend concurrency io
io.sniffer io.sniffer.bsd io.unix.backend ; io.sniffer.backend io.sniffer.bsd io.unix.backend ;
IN: channels.sniffer.bsd
M: unix-io sniff-channel ( -- channel ) M: unix-io sniff-channel ( -- channel )
"/dev/bpf0" "en1" <sniffer-spec> <sniffer> <channel> [ "/dev/bpf0" "en1" <sniffer-spec> <sniffer> <channel> [

View File

@ -3,11 +3,9 @@
! !
! Wrap a sniffer in a channel ! Wrap a sniffer in a channel
USING: kernel channels concurrency io io.backend USING: kernel channels concurrency io io.backend
io.sniffer system vocabs.loader ; io.sniffer io.sniffer.backend system vocabs.loader ;
: (sniff-channel) ( stream channel -- ) : (sniff-channel) ( stream channel -- )
4096 pick stream-read-partial over to (sniff-channel) ; 4096 pick stream-read-partial over to (sniff-channel) ;
HOOK: sniff-channel io-backend ( -- channel )
bsd? [ "channels.sniffer.bsd" require ] when bsd? [ "channels.sniffer.bsd" require ] when

View File

@ -1,5 +1,6 @@
! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither. ! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
USING: help.markup help.syntax coroutines ; USING: help.markup help.syntax ;
IN: coroutines
HELP: cocreate HELP: cocreate
{ $values { "quot" "a quotation with stack effect ( value -- )" } { "co" "a coroutine" } } { $values { "quot" "a quotation with stack effect ( value -- )" } { "co" "a coroutine" } }

View File

@ -12,14 +12,11 @@ USING: alien kernel system combinators alien.syntax ;
IN: cryptlib.libcl IN: cryptlib.libcl
: load-libcl ( -- ) << "libcl" {
"libcl" {
{ [ win32? ] [ "cl32.dll" "stdcall" ] } { [ win32? ] [ "cl32.dll" "stdcall" ] }
{ [ macosx? ] [ "libcl.dylib" "cdecl" ] } { [ macosx? ] [ "libcl.dylib" "cdecl" ] }
{ [ unix? ] [ "libcl.so" "cdecl" ] } { [ unix? ] [ "libcl.so" "cdecl" ] }
} cond add-library ; parsing } cond add-library >>
load-libcl
! =============================================== ! ===============================================
! Machine-dependant types ! Machine-dependant types

View File

@ -1,5 +1,6 @@
USING: help.markup help.syntax kernel math sequences quotations USING: help.markup help.syntax kernel math sequences quotations
crypto.common crypto.md5 ; crypto.common ;
IN: crypto.md5
HELP: stream>md5 HELP: stream>md5
{ $values { "stream" "a stream" } { "byte-array" "md5 hash" } } { $values { "stream" "a stream" } { "byte-array" "md5 hash" } }

View File

@ -1,5 +1,4 @@
USING: definitions help help.markup help.syntax io io.files USING: definitions help help.markup help.syntax io io.files editors words ;
editors words ;
IN: editors.vim IN: editors.vim
ARTICLE: { "vim" "vim" } "Vim support" ARTICLE: { "vim" "vim" } "Vim support"

View File

@ -1,6 +1,6 @@
! -*-factor-*- ! -*-factor-*-
USING: kernel unix vars mortar slot-accessors USING: kernel unix vars mortar mortar.sugar slot-accessors
x.widgets.wm.menu x.widgets.wm.unmapped-frames-menu x.widgets.wm.menu x.widgets.wm.unmapped-frames-menu
factory.commands factory.load ; factory.commands factory.load ;

View File

@ -1,6 +1,6 @@
USING: kernel parser io io.files namespaces sequences editors threads vars USING: kernel parser io io.files namespaces sequences editors threads vars
mortar slot-accessors mortar mortar.sugar slot-accessors
x x
x.widgets.wm.root x.widgets.wm.root
x.widgets.wm.frame x.widgets.wm.frame

View File

@ -0,0 +1,14 @@
IN: hardware-info.backend
SYMBOL: os
HOOK: cpus os ( -- n )
HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n )
HOOK: total-page-file os ( -- n )
HOOK: available-page-file os ( -- n )
HOOK: total-virtual-mem os ( -- n )
HOOK: available-virtual-mem os ( -- n )
HOOK: available-virtual-extended-mem os ( -- n )

View File

@ -1,26 +1,15 @@
USING: alien.syntax math prettyprint system combinators USING: alien.syntax kernel math prettyprint system
vocabs.loader ; combinators vocabs.loader hardware-info.backend ;
IN: hardware-info IN: hardware-info
SYMBOL: os
HOOK: cpus os ( -- n )
HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n )
HOOK: total-page-file os ( -- n )
HOOK: available-page-file os ( -- n )
HOOK: total-virtual-mem os ( -- n )
HOOK: available-virtual-mem os ( -- n )
HOOK: available-virtual-extended-mem os ( -- n )
: kb. ( x -- ) 10 2^ /f . ; : kb. ( x -- ) 10 2^ /f . ;
: megs. ( x -- ) 20 2^ /f . ; : megs. ( x -- ) 20 2^ /f . ;
: gigs. ( x -- ) 30 2^ /f . ; : gigs. ( x -- ) 30 2^ /f . ;
{ << {
{ [ windows? ] [ "hardware-info.windows" ] } { [ windows? ] [ "hardware-info.windows" ] }
{ [ linux? ] [ "hardware-info.linux" ] } { [ linux? ] [ "hardware-info.linux" ] }
{ [ macosx? ] [ "hardware-info.macosx" ] } { [ macosx? ] [ "hardware-info.macosx" ] }
} cond require { [ t ] [ f ] }
} cond [ require ] when* >>

View File

@ -1,5 +1,5 @@
USING: alien alien.c-types alien.syntax byte-arrays kernel USING: alien alien.c-types alien.syntax byte-arrays kernel
namespaces sequences unix hardware-info ; namespaces sequences unix hardware-info.backend ;
IN: hardware-info.macosx IN: hardware-info.macosx
TUPLE: macosx ; TUPLE: macosx ;

View File

@ -1,5 +1,6 @@
USING: alien.c-types hardware-info hardware-info.windows USING: alien.c-types hardware-info hardware-info.windows
kernel math namespaces windows windows.kernel32 ; kernel math namespaces windows windows.kernel32
hardware-info.backend ;
IN: hardware-info.windows.ce IN: hardware-info.windows.ce
T{ wince } os set-global T{ wince } os set-global
@ -29,5 +30,3 @@ M: wince total-virtual-mem ( -- n )
M: wince available-virtual-mem ( -- n ) M: wince available-virtual-mem ( -- n )
memory-status MEMORYSTATUS-dwAvailVirtual ; memory-status MEMORYSTATUS-dwAvailVirtual ;

View File

@ -1,5 +1,5 @@
USING: alien alien.c-types hardware-info hardware-info.windows USING: alien alien.c-types hardware-info hardware-info.windows
kernel libc math namespaces kernel libc math namespaces hardware-info.backend
windows windows.advapi32 windows.kernel32 ; windows windows.advapi32 windows.kernel32 ;
IN: hardware-info.windows.nt IN: hardware-info.windows.nt

View File

@ -1,6 +1,6 @@
USING: alien alien.c-types kernel libc math namespaces USING: alien alien.c-types kernel libc math namespaces
windows windows.kernel32 windows.advapi32 hardware-info windows windows.kernel32 windows.advapi32
words combinators vocabs.loader ; words combinators vocabs.loader hardware-info.backend ;
IN: hardware-info.windows IN: hardware-info.windows
TUPLE: wince ; TUPLE: wince ;
@ -70,7 +70,8 @@ M: windows cpus ( -- n )
: system-windows-directory ( -- str ) : system-windows-directory ( -- str )
\ GetSystemWindowsDirectory get-directory ; \ GetSystemWindowsDirectory get-directory ;
{ << {
{ [ wince? ] [ "hardware-info.windows.ce" ] } { [ wince? ] [ "hardware-info.windows.ce" ] }
{ [ winnt? ] [ "hardware-info.windows.nt" ] } { [ winnt? ] [ "hardware-info.windows.nt" ] }
} cond require { [ t ] [ f ] }
} cond [ require ] when* >>

View File

@ -2,7 +2,6 @@ USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting namespaces prettyprint quotations sequences splitting
state-parser strings ; state-parser strings ;
USING: html.parser ;
IN: html.parser.utils IN: html.parser.utils
: string-parse-end? : string-parse-end?

View File

@ -1,6 +1,7 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax http.basic-authentication crypto.sha2 ; USING: help.markup help.syntax crypto.sha2 ;
IN: http.basic-authentication
HELP: realms HELP: realms
{ $description { $description

View File

@ -1,6 +1,7 @@
! Coyright (C) 2007 Adam Wendt ! Coyright (C) 2007 Adam Wendt
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: id3 help.syntax help.markup ; USING: help.syntax help.markup ;
IN: id3
ARTICLE: "id3-tags" "ID3 Tags" ARTICLE: "id3-tags" "ID3 Tags"
"The " { $vocab-link "id3" } " vocabulary is used to read ID3 tags from MP3 audio streams." "The " { $vocab-link "id3" } " vocabulary is used to read ID3 tags from MP3 audio streams."

View File

@ -1,4 +1,5 @@
USING: inverse help.syntax help.markup ; USING: help.syntax help.markup ;
IN: inverse
HELP: [undo] HELP: [undo]
{ $values { "quot" "a quotation" } { "undo" "the inverse of the quotation" } } { $values { "quot" "a quotation" } { "undo" "the inverse of the quotation" } }

View File

@ -63,7 +63,9 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
{ {
{ [ dup word? not over symbol? or ] [ , ] } { [ dup word? not over symbol? or ] [ , ] }
{ [ dup explicit-inverse? ] [ , ] } { [ dup explicit-inverse? ] [ , ] }
{ [ dup compound? over { if dispatch } member? not and ] ! { [ dup compound? over { if dispatch } member? not and ]
! [ word-def [ inline-word ] each ] }
{ [ dup word? over { if dispatch } member? not and ]
[ word-def [ inline-word ] each ] } [ word-def [ inline-word ] each ] }
{ [ drop t ] [ "Quotation is not invertible" throw ] } { [ drop t ] [ "Quotation is not invertible" throw ] }
} cond ; } cond ;

View File

@ -0,0 +1,6 @@
USING: io.backend kernel system vocabs.loader ;
IN: io.sniffer.backend
SYMBOL: sniffer-type
TUPLE: sniffer ;
HOOK: <sniffer> io-backend ( obj -- sniffer )

View File

@ -1,9 +1,9 @@
! Copyright (C) 2007 Elie Chaftari, Doug Coleman. ! Copyright (C) 2007 Elie Chaftari, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax destructors hexdump io USING: alien.c-types alien.syntax destructors hexdump io
io.buffers io.nonblocking io.sniffer io.sockets io.streams.lines io.buffers io.nonblocking io.sockets io.streams.lines
io.unix.backend io.unix.files kernel libc locals math qualified io.unix.backend io.unix.files kernel libc locals math qualified
sequences ; sequences io.sniffer.backend ;
QUALIFIED: unix QUALIFIED: unix
IN: io.sniffer.bsd IN: io.sniffer.bsd

View File

@ -0,0 +1,17 @@
USING: byte-arrays combinators io io.backend
io.sockets.headers io.sniffer.backend kernel
prettyprint sequences ;
IN: io.sniffer.filter.backend
HOOK: sniffer-loop io-backend ( stream -- )
HOOK: packet. io-backend ( string -- )
: (packet.) ( string -- )
dup 14 head >byte-array
"--Ethernet Header--" print
dup etherneth.
dup etherneth-type {
! HEX: 800 [ ] ! IP
! HEX: 806 [ ] ! ARP
[ "Unknown type: " write .h ]
} case 2drop ;

View File

@ -1,7 +1,8 @@
USING: alien.c-types hexdump io io.backend io.sockets.headers USING: alien.c-types hexdump io io.backend io.sockets.headers
io.sockets.headers.bsd kernel io.sniffer io.sniffer.bsd io.sockets.headers.bsd kernel io.sniffer io.sniffer.bsd
io.sniffer.filter io.streams.string io.unix.backend math io.streams.string io.unix.backend math
sequences system byte-arrays ; sequences system byte-arrays io.sniffer.filter.backend
io.sniffer.filter.backend io.sniffer.backend ;
IN: io.sniffer.filter.bsd IN: io.sniffer.filter.bsd
! http://www.iana.org/assignments/ethernet-numbers ! http://www.iana.org/assignments/ethernet-numbers

View File

@ -1,19 +1,8 @@
USING: alien.c-types byte-arrays combinators hexdump io USING: alien.c-types byte-arrays combinators hexdump io
io.backend io.streams.string io.sockets.headers kernel math io.backend io.streams.string io.sockets.headers kernel math
prettyprint io.sniffer sequences system vocabs.loader ; prettyprint io.sniffer sequences system vocabs.loader
io.sniffer.filter.backend ;
IN: io.sniffer.filter IN: io.sniffer.filter
HOOK: sniffer-loop io-backend ( stream -- )
HOOK: packet. io-backend ( string -- )
: (packet.) ( string -- )
dup 14 head >byte-array
"--Ethernet Header--" print
dup etherneth.
dup etherneth-type {
! HEX: 800 [ ] ! IP
! HEX: 806 [ ] ! ARP
[ "Unknown type: " write .h ]
} case 2drop ;
bsd? [ "io.sniffer.filter.bsd" require ] when bsd? [ "io.sniffer.filter.bsd" require ] when

View File

@ -1,10 +1,4 @@
USING: io.backend kernel system vocabs.loader ; USING: io.backend kernel system vocabs.loader ;
IN: io.sniffer IN: io.sniffer
SYMBOL: sniffer-type
TUPLE: sniffer ;
HOOK: <sniffer> io-backend ( obj -- sniffer )
bsd? [ "io.sniffer.bsd" require ] when bsd? [ "io.sniffer.bsd" require ] when

View File

@ -1,4 +1,4 @@
USING: kernel opengl arrays sequences jamshred jamshred.tunnel USING: kernel opengl arrays sequences jamshred.tunnel
jamshred.player math.vectors ; jamshred.player math.vectors ;
IN: jamshred.game IN: jamshred.game

View File

@ -1,4 +1,4 @@
USING: colors jamshred.game jamshred.oint jamshred.tunnel kernel USING: colors jamshred.oint jamshred.tunnel kernel
math math.constants sequences ; math math.constants sequences ;
IN: jamshred.player IN: jamshred.player

View File

@ -1,6 +1,7 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax json.reader ; USING: help.markup help.syntax ;
IN: json.reader
HELP: json> "( string -- object )" HELP: json> "( string -- object )"
{ $values { "string" "a string in JSON format" } { "object" "yhe object deserialized from the JSON string" } } { $values { "string" "a string in JSON format" } { "object" "yhe object deserialized from the JSON string" } }

View File

@ -1,6 +1,7 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax json.writer ; USING: help.markup help.syntax ;
IN: json.writer
HELP: >json "( obj -- string )" HELP: >json "( obj -- string )"
{ $values { "obj" "an object" } { "string" "the object converted to JSON format" } } { $values { "obj" "an object" } { "string" "the object converted to JSON format" } }

View File

@ -13,7 +13,7 @@ GENERIC: json-print ( obj -- )
[ json-print ] string-out ; [ json-print ] string-out ;
M: f json-print ( f -- ) M: f json-print ( f -- )
"false" write ; drop "false" write ;
M: string json-print ( obj -- ) M: string json-print ( obj -- )
CHAR: " write1 "\"" split "\\\"" join CHAR: \r swap remove "\n" split "\\r\\n" join write CHAR: " write1 ; CHAR: " write1 "\"" split "\\\"" join CHAR: \r swap remove "\n" split "\\r\\n" join write CHAR: " write1 ;

View File

@ -5,7 +5,7 @@ USING: kernel parser namespaces io prettyprint math arrays sequences
IN: lisp.listener IN: lisp.listener
: parse-stdio ( -- quot/f ) stdio get parse-interactive ; : parse-stdio ( -- quot/f ) stdio get read-quot ;
: stuff? ( -- ? ) datastack length 0 > ; : stuff? ( -- ? ) datastack length 0 > ;

View File

@ -4,14 +4,11 @@
USING: alien alien.c-types alien.syntax combinators kernel math system ; USING: alien alien.c-types alien.syntax combinators kernel math system ;
IN: mad IN: mad
: load-mad-library ( -- ) << "mad" {
"mad" {
{ [ macosx? ] [ "libmad.0.dylib" ] } { [ macosx? ] [ "libmad.0.dylib" ] }
{ [ unix? ] [ "libmad.so" ] } { [ unix? ] [ "libmad.so" ] }
{ [ windows? ] [ "mad.dll" ] } { [ windows? ] [ "mad.dll" ] }
} cond "cdecl" add-library ; parsing } cond "cdecl" add-library >>
load-mad-library
LIBRARY: mad LIBRARY: mad

View File

@ -26,10 +26,8 @@ TUPLE: positive-even-expected n ;
dup even? [ -1 shift >r 1+ r> (factor-2s) ] when ; dup even? [ -1 shift >r 1+ r> (factor-2s) ] when ;
: factor-2s ( n -- r s ) : factor-2s ( n -- r s )
#! factor an even number into s * 2 ^ r #! factor an integer into s * 2^r
dup even? over 0 > and [ 0 swap (factor-2s) ;
positive-even-expected construct-boa throw
] unless 0 swap (factor-2s) ;
:: (miller-rabin) | n prime?! | :: (miller-rabin) | n prime?! |
n 1- factor-2s s set r set n 1- factor-2s s set r set

View File

@ -1,20 +1,23 @@
USING: help.markup help.syntax ; USING: help.markup help.syntax math sequences ;
IN: math.primes.factors IN: math.primes.factors
{ factors count-factors unique-factors } related-words { factors group-factors unique-factors } related-words
HELP: factors HELP: factors
{ $values { "n" "a positive integer" } { "seq" "a sequence" } } { $values { "n" "a positive integer" } { "seq" sequence } }
{ $description { "Factorize an integer and return an ordered list of factors, possibly repeated." } } ; { $description { "Return an ordered list of a number's prime factors, possibly repeated." } }
{ $examples { $example "300 factors ." "{ 2 2 3 5 5 }" } } ;
HELP: count-factors HELP: group-factors
{ $values { "n" "a positive integer" } { "seq" "a sequence" } } { $values { "n" "a positive integer" } { "seq" sequence } }
{ $description { "Return a sequence of pairs representing each factor in the number and its corresponding power." } } ; { $description { "Return a sequence of pairs representing each prime factor in the number and its corresponding power (multiplicity)." } }
{ $examples { $example "300 group-factors ." "{ { 2 2 } { 3 1 } { 5 2 } }" } } ;
HELP: unique-factors HELP: unique-factors
{ $values { "n" "a positive integer" } { "seq" "a sequence" } } { $values { "n" "a positive integer" } { "seq" sequence } }
{ $description { "Return an ordered list of unique prime factors." } } ; { $description { "Return an ordered list of a number's unique prime factors." } }
{ $examples { $example "300 unique-factors ." "{ 2 3 5 }" } } ;
HELP: totient HELP: totient
{ $values { "n" "a positive integer" } { "t" "an integer" } } { $values { "n" "a positive integer" } { "t" integer } }
{ $description { "Return the number of integers between 1 and " { $snippet "n-1" } " relatively prime to " { $snippet "n" } "." } } ; { $description { "Return the number of integers between 1 and " { $snippet "n-1" } " that are relatively prime to " { $snippet "n" } "." } } ;

View File

@ -1,6 +1,6 @@
USING: math.primes.factors tools.test ; USING: math.primes.factors tools.test ;
{ { 999983 999983 1000003 } } [ 999969000187000867 factors ] unit-test { { 999983 999983 1000003 } } [ 999969000187000867 factors ] unit-test
{ { { 999983 2 } { 1000003 1 } } } [ 999969000187000867 count-factors ] unit-test { { { 999983 2 } { 1000003 1 } } } [ 999969000187000867 group-factors ] unit-test
{ { 999983 1000003 } } [ 999969000187000867 unique-factors ] unit-test { { 999983 1000003 } } [ 999969000187000867 unique-factors ] unit-test
{ 999967000236000612 } [ 999969000187000867 totient ] unit-test { 999967000236000612 } [ 999969000187000867 totient ] unit-test

View File

@ -27,7 +27,7 @@ PRIVATE>
: factors ( n -- seq ) : factors ( n -- seq )
[ (factor) ] (decompose) ; foldable [ (factor) ] (decompose) ; foldable
: count-factors ( n -- seq ) : group-factors ( n -- seq )
[ (count) ] (decompose) ; foldable [ (count) ] (decompose) ; foldable
: unique-factors ( n -- seq ) : unique-factors ( n -- seq )
@ -37,5 +37,5 @@ PRIVATE>
dup 2 < [ dup 2 < [
drop 0 drop 0
] [ ] [
[ unique-factors dup 1 [ 1- * ] reduce swap product / ] keep * dup unique-factors dup 1 [ 1- * ] reduce swap product / *
] if ; foldable ] if ; foldable

View File

@ -128,7 +128,7 @@ over object-class class-methods 1 head* assoc-stack call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: new* ( class -- object ) <<- create ; ! : new* ( class -- object ) <<- create ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -136,13 +136,20 @@ IN: slot-accessors
IN: mortar IN: mortar
! : generate-slot-getter ( name -- )
! "$" over append "slot-accessors" create swap [ slot-value ] curry
! define-compound ;
: generate-slot-getter ( name -- ) : generate-slot-getter ( name -- )
"$" over append "slot-accessors" create swap [ slot-value ] curry "$" over append "slot-accessors" create swap [ slot-value ] curry define ;
define-compound ;
! : generate-slot-setter ( name -- )
! ">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
! define-compound ;
: generate-slot-setter ( name -- ) : generate-slot-setter ( name -- )
">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry ">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
define-compound ; define ;
: generate-slot-accessors ( name -- ) : generate-slot-accessors ( name -- )
dup dup

View File

@ -0,0 +1,6 @@
USING: mortar ;
IN: mortar.sugar
: new* ( class -- object ) <<- create ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup parser-combinators USING: help.syntax help.markup parser-combinators ;
parser-combinators.simple ; IN: parser-combinators.simple
HELP: 'digit' HELP: 'digit'
{ $values { $values

View File

@ -24,14 +24,18 @@ IN: project-euler.006
! SOLUTION ! SOLUTION
! -------- ! --------
<PRIVATE
: sum-of-squares ( seq -- n ) : sum-of-squares ( seq -- n )
0 [ sq + ] reduce ; 0 [ sq + ] reduce ;
: square-of-sums ( seq -- n ) : square-of-sum ( seq -- n )
0 [ + ] reduce sq ; sum sq ;
PRIVATE>
: euler006 ( -- answer ) : euler006 ( -- answer )
1 100 [a,b] dup sum-of-squares swap square-of-sums - abs ; 1 100 [a,b] dup sum-of-squares swap square-of-sum - abs ;
! [ euler006 ] 100 ave-time ! [ euler006 ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials ! 0 ms run / 0 ms GC ave time - 100 trials

View File

@ -0,0 +1,71 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.primes math.ranges sequences ;
IN: project-euler.026
! http://projecteuler.net/index.php?section=problems&id=26
! DESCRIPTION
! -----------
! A unit fraction contains 1 in the numerator. The decimal representation of
! the unit fractions with denominators 2 to 10 are given:
! 1/2 = 0.5
! 1/3 = 0.(3)
! 1/4 = 0.25
! 1/5 = 0.2
! 1/6 = 0.1(6)
! 1/7 = 0.(142857)
! 1/8 = 0.125
! 1/9 = 0.(1)
! 1/10 = 0.1
! Where 0.1(6) means 0.166666..., and has a 1-digit recurring cycle. It can be
! seen that 1/7 has a 6-digit recurring cycle.
! Find the value of d < 1000 for which 1/d contains the longest recurring cycle
! in its decimal fraction part.
! SOLUTION
! --------
<PRIVATE
: source-026 ( -- seq )
1 1000 (a,b) [ prime? ] subset [ 1 swap / ] map ;
: (mult-order) ( n a m -- k )
3dup ^ swap mod 1 = [ 2nip ] [ 1+ (mult-order) ] if ;
PRIVATE>
: coprime? ( m n -- ? )
gcd 1 = nip ;
: recurring-period? ( a/b -- ? )
denominator 10 coprime? ;
! Multiplicative order a.k.a. modulo order
: mult-order ( a n -- k )
swap 1 (mult-order) ;
: period-length ( a/b -- n )
dup recurring-period? [ denominator 10 swap mult-order ] [ drop 0 ] if ;
<PRIVATE
: max-period ( seq -- elt n )
dup [ period-length ] map dup supremum
over index [ swap nth ] curry 2apply ;
PRIVATE>
: euler026 ( -- answer )
source-026 max-period drop denominator ;
! [ euler026 ] 100 ave-time
! 724 ms run / 7 ms GC ave time - 100 trials
MAIN: euler026

View File

@ -34,9 +34,6 @@ IN: project-euler.common
: propagate ( bottom top -- newtop ) : propagate ( bottom top -- newtop )
[ over 1 tail rot first2 max rot + ] map nip ; [ over 1 tail rot first2 max rot + ] map nip ;
: reduce-2s ( n -- r s )
dup even? [ factor-2s >r 1+ r> ] [ 1 swap ] if ;
: shift-3rd ( seq obj obj -- seq obj obj ) : shift-3rd ( seq obj obj -- seq obj obj )
rot 1 tail -rot ; rot 1 tail -rot ;
@ -88,11 +85,11 @@ PRIVATE>
! The divisor function, counts the number of divisors ! The divisor function, counts the number of divisors
: tau ( m -- n ) : tau ( m -- n )
count-factors flip second 1 [ 1+ * ] reduce ; group-factors flip second 1 [ 1+ * ] reduce ;
! Optimized brute-force, is often faster than prime factorization ! Optimized brute-force, is often faster than prime factorization
: tau* ( m -- n ) : tau* ( m -- n )
reduce-2s [ perfect-square? -1 0 ? ] keep factor-2s [ 1+ ] dip [ perfect-square? -1 0 ? ] keep
dup sqrt >fixnum [1,b] [ dup sqrt >fixnum [1,b] [
dupd mod zero? [ >r 2 + r> ] when dupd mod zero? [ [ 2 + ] dip ] when
] each drop * ; ] each drop * ;

View File

@ -8,8 +8,8 @@ USING: definitions io io.files kernel math.parser sequences vocabs
project-euler.013 project-euler.014 project-euler.015 project-euler.016 project-euler.013 project-euler.014 project-euler.015 project-euler.016
project-euler.017 project-euler.018 project-euler.019 project-euler.020 project-euler.017 project-euler.018 project-euler.019 project-euler.020
project-euler.021 project-euler.022 project-euler.023 project-euler.024 project-euler.021 project-euler.022 project-euler.023 project-euler.024
project-euler.025 project-euler.067 project-euler.134 project-euler.169 project-euler.025 project-euler.026 project-euler.067 project-euler.134
project-euler.173 project-euler.175 ; project-euler.169 project-euler.173 project-euler.175 ;
IN: project-euler IN: project-euler
<PRIVATE <PRIVATE

View File

@ -1,5 +1,6 @@
USING: kernel namespaces arrays x11.xlib mortar slot-accessors x x.font ; USING: kernel namespaces arrays x11.xlib mortar mortar.sugar
slot-accessors x x.font ;
IN: x.gc IN: x.gc

View File

@ -1,5 +1,5 @@
USING: kernel arrays math.vectors mortar x.gc slot-accessors geom.pos ; USING: kernel arrays math.vectors mortar mortar.sugar x.gc slot-accessors geom.pos ;
IN: x.pen IN: x.pen

View File

@ -1,6 +1,6 @@
USING: kernel combinators math x11.xlib USING: kernel combinators math x11.xlib
mortar slot-accessors x.gc x.widgets.label ; mortar mortar.sugar slot-accessors x.gc x.widgets.label ;
IN: x.widgets.button IN: x.widgets.button
@ -11,7 +11,7 @@ SYMBOL: <button>
{ "action-1" "action-2" "action-3" } accessors { "action-1" "action-2" "action-3" } accessors
define-simple-class define-simple-class
<button> "create" ( <button> -- button ) [ <button> "create" !( <button> -- button ) [
new-empty new-empty
<gc> new* >>gc ExposureMask ButtonPressMask bitor >>mask <- init-widget <gc> new* >>gc ExposureMask ButtonPressMask bitor >>mask <- init-widget
] add-class-method ] add-class-method

View File

@ -1,6 +1,6 @@
USING: kernel strings arrays sequences sequences.lib math x11.xlib USING: kernel strings arrays sequences sequences.lib math x11.xlib
mortar slot-accessors x x.pen x.widgets ; mortar mortar.sugar slot-accessors x x.pen x.widgets ;
IN: x.widgets.keymenu IN: x.widgets.keymenu

View File

@ -1,5 +1,5 @@
USING: kernel x11.xlib mortar slot-accessors x.gc x.widgets ; USING: kernel x11.xlib mortar mortar.sugar slot-accessors x.gc x.widgets ;
IN: x.widgets.label IN: x.widgets.label

View File

@ -1,6 +1,6 @@
USING: kernel combinators namespaces math.vectors x11.xlib x11.constants USING: kernel combinators namespaces math.vectors x11.xlib x11.constants
mortar slot-accessors x x.gc x.widgets.wm.frame.drag ; mortar mortar.sugar slot-accessors x x.gc x.widgets.wm.frame.drag ;
IN: x.widgets.wm.frame.drag.move IN: x.widgets.wm.frame.drag.move

View File

@ -1,6 +1,6 @@
USING: kernel combinators namespaces math.vectors x11.xlib x11.constants USING: kernel combinators namespaces math.vectors x11.xlib x11.constants
mortar slot-accessors geom.rect x x.gc x.widgets.wm.frame.drag ; mortar mortar.sugar slot-accessors geom.rect x x.gc x.widgets.wm.frame.drag ;
IN: x.widgets.wm.frame.drag.size IN: x.widgets.wm.frame.drag.size

View File

@ -2,7 +2,7 @@
USING: kernel io combinators namespaces quotations arrays sequences USING: kernel io combinators namespaces quotations arrays sequences
math math.vectors math math.vectors
x11.xlib x11.constants x11.xlib x11.constants
mortar slot-accessors mortar mortar.sugar slot-accessors
geom.rect geom.rect
x x.gc x.widgets x x.gc x.widgets
x.widgets.button x.widgets.button

View File

@ -1,5 +1,5 @@
USING: kernel x11.constants mortar slot-accessors x.widgets.keymenu ; USING: kernel x11.constants mortar mortar.sugar slot-accessors x.widgets.keymenu ;
IN: x.widgets.wm.menu IN: x.widgets.wm.menu

View File

@ -1,4 +1,5 @@
USING: xml-rpc help.syntax help.markup ; USING: help.syntax help.markup ;
IN: xml-rpc
HELP: send-rpc HELP: send-rpc
{ $values { "rpc" "an RPC data type" } { "xml" "an XML document" } } { $values { "rpc" "an RPC data type" } { "xml" "an XML document" } }