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

Merge branch 'master' of git://factorcode.org/git/factor

db4
John Benediktsson 2008-10-02 17:08:25 -07:00
parent 0e48ccb4da ae60340653
commit c9dada5f77
60 changed files with 318 additions and 314 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

0
extra/crypto/common/authors.txt → basis/hexdump/authors.txt Executable file → Normal file
View File

22
basis/hexdump/hexdump-docs.factor Normal file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel ;
IN: hexdump
HELP: hexdump.
{ $values { "sequence" "a sequence" } }
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time and writes it to standard out." } ;
HELP: hexdump
{ $values { "sequence" "a sequence" } { "string" "a string" } }
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time. Lines are separated by a newline character." }
{ $see-also hexdump. } ;
ARTICLE: "hexdump" "Hexdump"
"The " { $vocab-link "hexdump" } " vocabulary provides a traditional hexdump view of a sequence." $nl
"Write hexdump to string:"
{ $subsection hexdump }
"Write the hexdump to the output stream:"
{ $subsection hexdump. } ;
ABOUT: "hexdump"

0
extra/hexdump/hexdump-tests.factor → basis/hexdump/hexdump-tests.factor
View File

12
extra/hexdump/hexdump.factor → basis/hexdump/hexdump.factor
View File

@ -1,5 +1,8 @@
USING: arrays io io.streams.string kernel math math.parser namespaces
prettyprint sequences sequences.lib splitting grouping strings ascii ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io io.streams.string kernel math math.parser
namespaces prettyprint sequences splitting grouping strings
ascii ;
IN: hexdump
<PRIVATE
@ -21,11 +24,12 @@ IN: hexdump
nl ;
PRIVATE>
: hexdump ( seq -- str )
: hexdump ( sequence -- string )
[
dup length header.
16 <sliced-groups> [ line. ] each-index
] with-string-writer ;
: hexdump. ( seq -- )
: hexdump. ( sequence -- )
hexdump write ;

0
extra/hexdump/summary.txt → basis/hexdump/summary.txt
View File

3
extra/crypto/barrett/barrett-tests.factor
View File

@ -1,4 +1,7 @@
! Copyright (C) 2008 DoDoug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: crypto.barrett kernel math namespaces tools.test ;
IN: crypto.barrett.tests
[ HEX: 1f63edfb7e838622c7412eafaf0439cf0cdf3aae8bdd09e2de69b509a53883a83560d5ce50ea039e4 ] [ HEX: 827c67f31b2b46afa49ed95d7f7a3011e5875f7052d4c55437ce726d3c6ce0dc9c445fda63b6dc4e 16 barrett-mu ] unit-test

10
extra/crypto/barrett/barrett.factor
View File

@ -1,14 +1,12 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions ;
IN: crypto.barrett
: barrett-mu ( n size -- mu )
#! Calculates Barrett's reduction parameter mu
#! size = word size in bits (8, 16, 32, 64, ...)
! over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ;
[
[ log2 1+ ] [ / 2 * ] bi*
] [
2^ rot ^ swap /i
] 2bi ;
[ [ log2 1+ ] [ / 2 * ] bi* ]
[ 2^ rot ^ swap /i ] 2bi ;

17
extra/crypto/common/common.factor
View File

@ -1,17 +0,0 @@
USING: arrays kernel io io.binary sbufs splitting grouping
strings sequences namespaces math math.parser parser
hints math.bitwise assocs ;
IN: crypto.common
: (nth-int) ( string n -- int )
2 shift dup 4 + rot <slice> ; inline
: nth-int ( string n -- int ) (nth-int) le> ; inline
: update ( num var -- ) [ w+ ] change ; inline
SYMBOL: big-endian?
: mod-nth ( n seq -- elt )
#! 5 "abcd" -> b
[ length mod ] [ nth ] bi ;

2
extra/crypto/hmac/hmac.factor
View File

@ -1,4 +1,4 @@
USING: arrays combinators crypto.common checksums checksums.md5
USING: arrays combinators checksums checksums.md5
checksums.sha1 checksums.md5.private io io.binary io.files
io.streams.byte-array kernel math math.vectors memoize sequences
io.encodings.binary ;

40
extra/crypto/random.factor
View File

@ -1,40 +0,0 @@
USING: kernel math math-contrib sequences namespaces errors
hashtables words arrays parser compiler syntax io ;
IN: crypto
: make-bits ( quot numbits -- n | quot: -- 0/1 )
0 -rot [ drop dup call rot 1 shift bitor swap ] each drop ;
: random-bytes ( m -- n )
>r [ 2 random ] r> 8 * make-bits ;
! DEFER: random-bits
: add-bit ( bit integer -- integer ) 1 shift bitor ;
: append-bits ( inta intb nbits -- int ) swapd shift bitor ;
: large-random-bits ( n -- int )
#! random number with high bit and low bit enabled (odd)
2 swap ^ [ random ] keep -1 shift 1 bitor bitor ;
! : next-double ( -- f ) 53 random-bits 9007199254740992 /f ;
: 0count ( integer -- n ) 0 swap [ 0 = [ 1+ ] when ] each-bit ;
: 1count ( integer -- n ) 0 swap [ 1 = [ 1+ ] when ] each-bit ;
: bit-reverse-table
{
HEX: 00 HEX: 80 HEX: 40 HEX: C0 HEX: 20 HEX: A0 HEX: 60 HEX: E0 HEX: 10 HEX: 90 HEX: 50 HEX: D0 HEX: 30 HEX: B0 HEX: 70 HEX: F0
HEX: 08 HEX: 88 HEX: 48 HEX: C8 HEX: 28 HEX: A8 HEX: 68 HEX: E8 HEX: 18 HEX: 98 HEX: 58 HEX: D8 HEX: 38 HEX: B8 HEX: 78 HEX: F8
HEX: 04 HEX: 84 HEX: 44 HEX: C4 HEX: 24 HEX: A4 HEX: 64 HEX: E4 HEX: 14 HEX: 94 HEX: 54 HEX: D4 HEX: 34 HEX: B4 HEX: 74 HEX: F4
HEX: 0C HEX: 8C HEX: 4C HEX: CC HEX: 2C HEX: AC HEX: 6C HEX: EC HEX: 1C HEX: 9C HEX: 5C HEX: DC HEX: 3C HEX: BC HEX: 7C HEX: FC
HEX: 02 HEX: 82 HEX: 42 HEX: C2 HEX: 22 HEX: A2 HEX: 62 HEX: E2 HEX: 12 HEX: 92 HEX: 52 HEX: D2 HEX: 32 HEX: B2 HEX: 72 HEX: F2
HEX: 0A HEX: 8A HEX: 4A HEX: CA HEX: 2A HEX: AA HEX: 6A HEX: EA HEX: 1A HEX: 9A HEX: 5A HEX: DA HEX: 3A HEX: BA HEX: 7A HEX: FA
HEX: 06 HEX: 86 HEX: 46 HEX: C6 HEX: 26 HEX: A6 HEX: 66 HEX: E6 HEX: 16 HEX: 96 HEX: 56 HEX: D6 HEX: 36 HEX: B6 HEX: 76 HEX: F6
HEX: 0E HEX: 8E HEX: 4E HEX: CE HEX: 2E HEX: AE HEX: 6E HEX: EE HEX: 1E HEX: 9E HEX: 5E HEX: DE HEX: 3E HEX: BE HEX: 7E HEX: FE
HEX: 01 HEX: 81 HEX: 41 HEX: C1 HEX: 21 HEX: A1 HEX: 61 HEX: E1 HEX: 11 HEX: 91 HEX: 51 HEX: D1 HEX: 31 HEX: B1 HEX: 71 HEX: F1
HEX: 09 HEX: 89 HEX: 49 HEX: C9 HEX: 29 HEX: A9 HEX: 69 HEX: E9 HEX: 19 HEX: 99 HEX: 59 HEX: D9 HEX: 39 HEX: B9 HEX: 79 HEX: F9
HEX: 05 HEX: 85 HEX: 45 HEX: C5 HEX: 25 HEX: A5 HEX: 65 HEX: E5 HEX: 15 HEX: 95 HEX: 55 HEX: D5 HEX: 35 HEX: B5 HEX: 75 HEX: F5
HEX: 0D HEX: 8D HEX: 4D HEX: CD HEX: 2D HEX: AD HEX: 6D HEX: ED HEX: 1D HEX: 9D HEX: 5D HEX: DD HEX: 3D HEX: BD HEX: 7D HEX: FD
HEX: 03 HEX: 83 HEX: 43 HEX: C3 HEX: 23 HEX: A3 HEX: 63 HEX: E3 HEX: 13 HEX: 93 HEX: 53 HEX: D3 HEX: 33 HEX: B3 HEX: 73 HEX: F3
HEX: 0B HEX: 8B HEX: 4B HEX: CB HEX: 2B HEX: AB HEX: 6B HEX: EB HEX: 1B HEX: 9B HEX: 5B HEX: DB HEX: 3B HEX: BB HEX: 7B HEX: FB
HEX: 07 HEX: 87 HEX: 47 HEX: C7 HEX: 27 HEX: A7 HEX: 67 HEX: E7 HEX: 17 HEX: 97 HEX: 57 HEX: D7 HEX: 37 HEX: B7 HEX: 77 HEX: F7
HEX: 0F HEX: 8F HEX: 4F HEX: CF HEX: 2F HEX: AF HEX: 6F HEX: EF HEX: 1F HEX: 9F HEX: 5F HEX: DF HEX: 3F HEX: BF HEX: 7F HEX: FF
} ; inline

1
extra/crypto/rsa/rsa-tests.factor
View File

@ -1,4 +1,5 @@
USING: kernel math namespaces crypto.rsa tools.test ;
IN: crypto.rsa.tests
[ 123456789 ] [ 128 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test
[ 123456789 ] [ 129 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test

2
extra/crypto/rsa/rsa.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: math.miller-rabin kernel math math.functions namespaces
sequences accessors ;
IN: crypto.rsa

2
extra/crypto/summary.txt
View File

@ -1 +1 @@
Cryptographic algorithms implemented in Factor, such as MD5 and SHA1
HMAC, XOR, Barrett, RSA, Timing

19
extra/crypto/xor/xor-tests.factor
View File

@ -2,23 +2,24 @@ USING: continuations crypto.xor kernel strings tools.test ;
IN: crypto.xor.tests
! No key
[ "" dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
[ { } dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
[ V{ } dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
[ "" "asdf" dupd xor-crypt xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
[ "" dup xor-crypt ] [ T{ empty-xor-key } = ] must-fail-with
[ { } dup xor-crypt ] [ T{ empty-xor-key } = ] must-fail-with
[ V{ } dup xor-crypt ] [ T{ empty-xor-key } = ] must-fail-with
[ "" "asdf" dupd xor-crypt xor-crypt ] [ T{ empty-xor-key } = ] must-fail-with
! a xor a = 0
[ "\0\0\0\0\0\0\0" ] [ "abcdefg" dup xor-crypt ] unit-test
[ { 15 15 15 15 } ] [ { 10 10 10 10 } { 5 5 5 5 } xor-crypt ] unit-test
[ "asdf" ] [ "key" "asdf" dupd xor-crypt xor-crypt >string ] unit-test
[ "" ] [ "key" "" xor-crypt >string ] unit-test
[ "asdf" ] [ "asdf" "key" [ xor-crypt ] [ xor-crypt ] bi >string ] unit-test
[ "" ] [ "" "key" xor-crypt >string ] unit-test
[ "a longer message...!" ] [
"."
"a longer message...!" dupd xor-crypt xor-crypt >string
"a longer message...!"
"." [ xor-crypt ] [ xor-crypt ] bi >string
] unit-test
[ "a longer message...!" ] [
"a longer message...!"
"a very long key, longer than the message even."
"a longer message...!" dupd xor-crypt xor-crypt >string
[ xor-crypt ] [ xor-crypt ] bi >string
] unit-test

14
extra/crypto/xor/xor.factor
View File

@ -1,8 +1,12 @@
USING: crypto.common kernel math sequences ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences fry ;
IN: crypto.xor
ERROR: no-xor-key ;
: mod-nth ( n seq -- elt ) [ length mod ] [ nth ] bi ;
: xor-crypt ( key seq -- seq' )
over empty? [ no-xor-key ] when
dup length rot [ mod-nth bitxor ] curry 2map ;
ERROR: empty-xor-key ;
: xor-crypt ( seq key -- seq' )
dup empty? [ empty-xor-key ] when
[ dup length ] dip '[ _ mod-nth bitxor ] 2map ;

2
extra/descriptive/descriptive.factor
View File

@ -1,4 +1,4 @@
USING: words kernel sequences combinators.lib locals
USING: words kernel sequences locals
locals.private accessors parser namespaces continuations
summary definitions generalizations arrays ;
IN: descriptive

4
extra/faq/faq.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml kernel sequences xml.utilities combinators.lib
math xml.data arrays assocs xml.generator xml.writer namespaces
USING: xml kernel sequences xml.utilities math xml.data
arrays assocs xml.generator xml.writer namespaces
make math.parser io accessors ;
IN: faq

1
extra/hexdump/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

12
extra/hexdump/hexdump-docs.factor
View File

@ -1,12 +0,0 @@
USING: help.markup help.syntax kernel ;
IN: hexdump
HELP: hexdump.
{ $values { "seq" "a sequence" } }
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time and writes it to standard out." } ;
HELP: hexdump
{ $values { "seq" "a sequence" } { "str" "a string" } }
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time. Lines are separated by a newline character." }
{ $see-also hexdump. } ;

31
extra/io/paths/paths.factor
View File

@ -1,14 +1,16 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel sequences accessors
dlists deques arrays sequences.lib ;
dlists deques arrays ;
IN: io.paths
TUPLE: directory-iterator path bfs queue ;
: qualified-directory ( path -- seq )
dup directory [ first2 >r append-path r> 2array ] with map ;
dup directory [ first2 [ append-path ] dip 2array ] with map ;
: push-directory ( path iter -- )
>r qualified-directory r> [
[ qualified-directory ] dip [
dup queue>> swap bfs>>
[ push-front ] [ push-back ] if
] curry each ;
@ -24,27 +26,24 @@ TUPLE: directory-iterator path bfs queue ;
] if ;
: iterate-directory ( iter quot -- obj )
2dup >r >r >r next-file dup [
r> call dup [
r> r> 2drop
] [
drop r> r> iterate-directory
] if
over next-file [
over call
[ 2drop ] [ iterate-directory ] if
] [
drop r> r> r> 3drop f
] if ; inline
2drop f
] if* ; inline recursive
: find-file ( path bfs? quot -- path/f )
>r <directory-iterator> r>
[ <directory-iterator> ] dip
[ keep and ] curry iterate-directory ; inline
: each-file ( path bfs? quot -- )
>r <directory-iterator> r>
[ <directory-iterator> ] dip
[ f ] compose iterate-directory drop ; inline
: find-all-files ( path bfs? quot -- paths )
>r <directory-iterator> r>
pusher >r [ f ] compose iterate-directory drop r> ; inline
[ <directory-iterator> ] dip
pusher [ [ f ] compose iterate-directory drop ] dip ; inline
: recursive-directory ( path bfs? -- paths )
[ ] accumulator >r each-file r> ;
[ ] accumulator [ each-file ] dip ;

6
extra/lisp/lisp.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg sequences arrays strings combinators.lib
USING: kernel peg sequences arrays strings
namespaces combinators math locals locals.private locals.backend accessors
vectors syntax lisp.parser assocs parser sequences.lib words
vectors syntax lisp.parser assocs parser words
quotations fry lists summary combinators.short-circuit continuations multiline ;
IN: lisp
@ -180,4 +180,4 @@ M: no-such-var summary drop "No such variable" ;
: <LISP
"LISP>" parse-multiline-string define-lisp-builtins
lisp-string>factor parsed \ call parsed ; parsing
lisp-string>factor parsed \ call parsed ; parsing

4
extra/lisp/parser/parser.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg peg.ebnf math.parser sequences arrays strings
combinators.lib math fry accessors lists combinators.short-circuit ;
math fry accessors lists combinators.short-circuit ;
IN: lisp.parser
@ -36,4 +36,4 @@ atom = number
| string
s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
list-item = _ ( atom | s-expression ) _ => [[ second ]]
;EBNF
;EBNF

2
extra/money/money.factor
View File

@ -1,6 +1,6 @@
USING: io kernel math math.functions math.parser parser lexer
namespaces make sequences splitting grouping combinators
continuations sequences.lib ;
continuations ;
IN: money
: dollars/cents ( dollars -- dollars cents )

2
extra/parser-combinators/regexp/regexp.factor
View File

@ -1,6 +1,6 @@
USING: arrays combinators kernel lists math math.parser
namespaces parser lexer parser-combinators parser-combinators.simple
promises quotations sequences combinators.lib strings math.order
promises quotations sequences strings math.order
assocs prettyprint.backend memoize unicode.case unicode.categories
combinators.short-circuit accessors make io ;
IN: parser-combinators.regexp

2
extra/project-euler/014/014.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.lib combinators.short-circuit kernel
USING: arrays combinators.short-circuit kernel
math math.ranges namespaces make sequences sorting ;
IN: project-euler.014

2
extra/project-euler/017/017.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.ranges math.text.english sequences sequences.lib strings
USING: kernel math.ranges math.text.english sequences strings
ascii combinators.short-circuit ;
IN: project-euler.017

4
extra/project-euler/019/019.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar combinators kernel math math.ranges namespaces sequences
sequences.lib math.order ;
math.order ;
IN: project-euler.019
! http://projecteuler.net/index.php?section=problems&id=19
@ -32,7 +32,7 @@ IN: project-euler.019
: euler019 ( -- answer )
1901 2000 [a,b] [
12 [1,b] [ 1 zeller-congruence ] map-with
12 [1,b] [ 1 zeller-congruence ] with map
] map concat [ zero? ] count ;
! [ euler019 ] 100 ave-time

4
extra/project-euler/021/021.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib combinators.short-circuit kernel math math.functions
math.ranges namespaces project-euler.common sequences sequences.lib ;
USING: combinators.short-circuit kernel math math.functions
math.ranges namespaces project-euler.common sequences ;
IN: project-euler.021
! http://projecteuler.net/index.php?section=problems&id=21

2
extra/project-euler/022/022.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: ascii io.encodings.ascii io.files kernel math project-euler.common
sequences sequences.lib sorting splitting ;
sequences sorting splitting ;
IN: project-euler.022
! http://projecteuler.net/index.php?section=problems&id=22

2
extra/project-euler/030/030.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions project-euler.common sequences sequences.lib ;
USING: kernel math math.functions project-euler.common sequences ;
IN: project-euler.030
! http://projecteuler.net/index.php?section=problems&id=30

2
extra/project-euler/032/032.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib hashtables kernel math math.combinatorics math.functions
USING: hashtables kernel math math.combinatorics math.functions
math.parser math.ranges project-euler.common sequences sets ;
IN: project-euler.032

2
extra/project-euler/034/034.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.ranges project-euler.common sequences sequences.lib ;
USING: kernel math.ranges project-euler.common sequences ;
IN: project-euler.034
! http://projecteuler.net/index.php?section=problems&id=34

2
extra/project-euler/035/035.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.combinatorics math.parser math.primes
project-euler.common sequences sequences.lib sets ;
project-euler.common sequences sets ;
IN: project-euler.035
! http://projecteuler.net/index.php?section=problems&id=35

2
extra/project-euler/036/036.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib combinators.short-circuit kernel math.parser math.ranges
USING: combinators.short-circuit kernel math.parser math.ranges
project-euler.common sequences ;
IN: project-euler.036

2
extra/project-euler/039/039.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.lib kernel math math.ranges
USING: arrays kernel math math.ranges
namespaces project-euler.common sequences ;
IN: project-euler.039

2
extra/project-euler/042/042.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: ascii io.files kernel math math.functions namespaces make
project-euler.common sequences sequences.lib splitting io.encodings.ascii ;
project-euler.common sequences splitting io.encodings.ascii ;
IN: project-euler.042
! http://projecteuler.net/index.php?section=problems&id=42

4
extra/project-euler/043/043.factor
View File

@ -1,8 +1,8 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib combinators.short-circuit hashtables kernel math
USING: combinators.short-circuit hashtables kernel math
math.combinatorics math.parser math.ranges project-euler.common sequences
sequences.lib sorting sets ;
sorting sets ;
IN: project-euler.043
! http://projecteuler.net/index.php?section=problems&id=43

2
extra/project-euler/047/047.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.lib kernel math math.primes math.primes.factors
USING: arrays kernel math math.primes math.primes.factors
math.ranges namespaces sequences ;
IN: project-euler.047

2
extra/project-euler/052/052.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib combinators.short-circuit kernel math
USING: combinators.short-circuit kernel math
project-euler.common sequences sorting ;
IN: project-euler.052

6
extra/project-euler/055/055.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser project-euler.common sequences sequences.lib ;
USING: kernel math math.parser project-euler.common sequences ;
IN: project-euler.055
! http://projecteuler.net/index.php?section=problems&id=55
@ -49,8 +49,8 @@ IN: project-euler.055
: (lychrel?) ( n iteration -- ? )
dup 50 < [
>r add-reverse dup palindrome?
[ r> 2drop f ] [ r> 1+ (lychrel?) ] if
[ add-reverse ] dip over palindrome?
[ 2drop f ] [ 1+ (lychrel?) ] if
] [
2drop t
] if ;

2
extra/project-euler/059/059.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ascii assocs hashtables io.encodings.ascii io.files kernel math
math.parser namespaces make sequences sequences.lib sequences.private sorting
math.parser namespaces make sequences sequences.private sorting
splitting grouping strings sets accessors ;
IN: project-euler.059

4
extra/project-euler/075/075.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.lib kernel math math.ranges
namespaces project-euler.common sequences sequences.lib ;
USING: arrays kernel math math.ranges
namespaces project-euler.common sequences ;
IN: project-euler.075
! http://projecteuler.net/index.php?section=problems&id=75

2
extra/project-euler/116/116.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.ranges sequences sequences.lib ;
USING: kernel math math.ranges sequences ;
IN: project-euler.116
! http://projecteuler.net/index.php?section=problems&id=116

2
extra/project-euler/148/148.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions sequences sequences.lib ;
USING: kernel math math.functions sequences ;
IN: project-euler.148
! http://projecteuler.net/index.php?section=problems&id=148

3
extra/project-euler/151/151.factor
View File

@ -1,7 +1,6 @@
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs combinators kernel math math.order namespaces sequences
sequences.lib ;
USING: assocs combinators kernel math math.order namespaces sequences ;
IN: project-euler.151
! http://projecteuler.net/index.php?section=problems&id=151

2
extra/project-euler/186/186.factor
View File

@ -1,5 +1,5 @@
USING: circular disjoint-sets kernel math math.ranges
sequences sequences.lib ;
sequences ;
IN: project-euler.186
: (generator) ( k -- n )

2
extra/project-euler/190/190.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.lib math math.functions math.ranges locals ;
USING: kernel sequences math math.functions math.ranges locals ;
IN: project-euler.190
! http://projecteuler.net/index.php?section=problems&id=190

59
extra/taxes/usa/federal/federal.factor Normal file
View File

@ -0,0 +1,59 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math math.intervals
namespaces sequences money math.order taxes.usa.fica
taxes.usa.medicare taxes.usa taxes.usa.w4 ;
IN: taxes.usa.federal
! http://www.irs.gov/pub/irs-pdf/p15.pdf
! Table 7 ANNUAL Payroll Period
: federal-single ( -- triples )
{
{ 0 2650 DECIMAL: 0 }
{ 2650 10300 DECIMAL: .10 }
{ 10300 33960 DECIMAL: .15 }
{ 33960 79725 DECIMAL: .25 }
{ 79725 166500 DECIMAL: .28 }
{ 166500 359650 DECIMAL: .33 }
{ 359650 1/0. DECIMAL: .35 }
} ;
: federal-married ( -- triples )
{
{ 0 8000 DECIMAL: 0 }
{ 8000 23550 DECIMAL: .10 }
{ 23550 72150 DECIMAL: .15 }
{ 72150 137850 DECIMAL: .25 }
{ 137850 207700 DECIMAL: .28 }
{ 207700 365100 DECIMAL: .33 }
{ 365100 1/0. DECIMAL: .35 }
} ;
SINGLETON: federal
: <federal> ( -- obj )
federal federal-single federal-married <tax-table> ;
: federal-tax ( salary w4 tax-table -- n )
[ adjust-allowances ] 2keep marriage-table tax ;
M: federal adjust-allowances* ( salary w4 collector entity -- newsalary )
2drop calculate-w4-allowances - ;
M: federal withholding* ( salary w4 tax-table entity -- x )
drop
[ federal-tax ] 3keep drop
[ fica-tax ] 2keep
medicare-tax + + ;
: total-withholding ( salary w4 tax-table -- x )
dup entity>> dup federal = [
withholding*
] [
drop
[ drop <federal> federal withholding* ]
[ dup entity>> withholding* ] 3bi +
] if ;
: net ( salary w4 collector -- x )
>r dupd r> total-withholding - ;

17
extra/taxes/usa/fica/fica.factor Normal file
View File

@ -0,0 +1,17 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs.lib math math.order money ;
IN: taxes.usa.fica
: fica-tax-rate ( -- x ) DECIMAL: .062 ; inline
ERROR: fica-base-unknown year ;
: fica-base-rate ( year -- x )
H{
{ 2008 102000 }
{ 2007 97500 }
} [ fica-base-unknown ] unless-at ;
: fica-tax ( salary w4 -- x )
year>> fica-base-rate min fica-tax-rate * ;

15
extra/taxes/usa/futa/futa.factor Normal file
View File

@ -0,0 +1,15 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math math.intervals
namespaces sequences money math.order ;
IN: taxes.usa.futa
! Employer tax only, not withheld
: futa-tax-rate ( -- x ) DECIMAL: .062 ; inline
: futa-base-rate ( -- x ) 7000 ; inline
: futa-tax-offset-credit ( -- x ) DECIMAL: .054 ; inline
: futa-tax ( salary w4 -- x )
drop futa-base-rate min
futa-tax-rate futa-tax-offset-credit -
* ;

8
extra/taxes/usa/medicare/medicare.factor Normal file
View File

@ -0,0 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math money ;
IN: taxes.usa.medicare
! No base rate for medicare; all wages subject
: medicare-tax-rate ( -- x ) DECIMAL: .0145 ; inline
: medicare-tax ( salary w4 -- x ) drop medicare-tax-rate * ;

33
extra/taxes/usa/mn/mn.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math math.intervals
namespaces sequences money math.order usa-cities
taxes.usa taxes.usa.w4 ;
IN: taxes.usa.mn
! Minnesota
: mn-single ( -- triples )
{
{ 0 1950 DECIMAL: 0 }
{ 1950 23750 DECIMAL: .0535 }
{ 23750 73540 DECIMAL: .0705 }
{ 73540 1/0. DECIMAL: .0785 }
} ;
: mn-married ( -- triples )
{
{ 0 7400 DECIMAL: 0 }
{ 7400 39260 DECIMAL: .0535 }
{ 39260 133980 DECIMAL: .0705 }
{ 133980 1/0. DECIMAL: .0785 }
} ;
: <mn> ( -- obj )
MN mn-single mn-married <tax-table> ;
M: MN adjust-allowances* ( salary w4 collector entity -- newsalary )
2drop calculate-w4-allowances - ;
M: MN withholding* ( salary w4 collector entity -- x )
drop
[ adjust-allowances ] 2keep marriage-table tax ;

30
unmaintained/taxes/taxes-tests.factor → extra/taxes/usa/usa-tests.factor
View File

@ -1,5 +1,7 @@
USING: kernel money taxes tools.test ;
IN: taxes.tests
USING: kernel money tools.test
taxes.usa taxes.usa.federal taxes.usa.mn
taxes.utils taxes.usa.w4 usa-cities ;
IN: taxes.usa.tests
[
426 23
@ -42,14 +44,14 @@ IN: taxes.tests
[
780 81
] [
24000 2008 3 f <w4> <minnesota> net biweekly
24000 2008 3 f <w4> <mn> net biweekly
dollars/cents
] unit-test
[
818 76
] [
24000 2008 3 t <w4> <minnesota> net biweekly
24000 2008 3 t <w4> <mn> net biweekly
dollars/cents
] unit-test
@ -57,14 +59,14 @@ IN: taxes.tests
[
2124 39
] [
78250 2008 3 f <w4> <minnesota> net biweekly
78250 2008 3 f <w4> <mn> net biweekly
dollars/cents
] unit-test
[
2321 76
] [
78250 2008 3 t <w4> <minnesota> net biweekly
78250 2008 3 t <w4> <mn> net biweekly
dollars/cents
] unit-test
@ -72,45 +74,45 @@ IN: taxes.tests
[
2612 63
] [
100000 2008 3 f <w4> <minnesota> net biweekly
100000 2008 3 f <w4> <mn> net biweekly
dollars/cents
] unit-test
[
22244 52
] [
1000000 2008 3 f <w4> <minnesota> net biweekly
1000000 2008 3 f <w4> <mn> net biweekly
dollars/cents
] unit-test
[
578357 40
] [
1000000 2008 3 f <w4> <minnesota> net
1000000 2008 3 f <w4> <mn> net
dollars/cents
] unit-test
[
588325 41
] [
1000000 2008 3 t <w4> <minnesota> net
1000000 2008 3 t <w4> <mn> net
dollars/cents
] unit-test
[ 30 97 ] [
24000 2008 2 f <w4> <minnesota> withholding biweekly dollars/cents
24000 2008 2 f <w4> <mn> MN withholding* biweekly dollars/cents
] unit-test
[ 173 66 ] [
78250 2008 2 f <w4> <minnesota> withholding biweekly dollars/cents
78250 2008 2 f <w4> <mn> MN withholding* biweekly dollars/cents
] unit-test
[ 138 69 ] [
24000 2008 2 f <w4> <federal> withholding biweekly dollars/cents
24000 2008 2 f <w4> <federal> total-withholding biweekly dollars/cents
] unit-test
[ 754 72 ] [
78250 2008 2 f <w4> <federal> withholding biweekly dollars/cents
78250 2008 2 f <w4> <federal> total-withholding biweekly dollars/cents
] unit-test

32
extra/taxes/usa/usa.factor Normal file
View File

@ -0,0 +1,32 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math math.intervals
namespaces sequences money math.order taxes.usa.w4 ;
IN: taxes.usa
! Withhold: FICA, Medicare, Federal (FICA is social security)
TUPLE: tax-table entity single married ;
C: <tax-table> tax-table
GENERIC: adjust-allowances* ( salary w4 tax-table entity -- newsalary )
GENERIC: withholding* ( salary w4 tax-table entity -- x )
: adjust-allowances ( salary w4 tax-table -- newsalary )
dup entity>> adjust-allowances* ;
: withholding ( salary w4 tax-table -- x )
dup entity>> withholding* ;
: tax-bracket-range ( pair -- n ) first2 swap - ;
: tax-bracket ( tax salary triples -- tax salary )
[ [ tax-bracket-range min ] keep third * + ] 2keep
tax-bracket-range [-] ;
: tax ( salary triples -- x )
0 -rot [ tax-bracket ] each drop ;
: marriage-table ( w4 tax-table -- triples )
swap married?>>
[ married>> ] [ single>> ] if ;

13
extra/taxes/usa/w4/w4.factor Normal file
View File

@ -0,0 +1,13 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math ;
IN: taxes.usa.w4
! Each employee fills out a w4
TUPLE: w4 year allowances married? ;
C: <w4> w4
: allowance ( -- x ) 3500 ; inline
: calculate-w4-allowances ( w4 -- x ) allowances>> allowance * ;

10
extra/taxes/utils/utils.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: math ;
IN: taxes.utils
: monthly ( x -- y ) 12 / ;
: semimonthly ( x -- y ) 24 / ;
: biweekly ( x -- y ) 26 / ;
: weekly ( x -- y ) 52 / ;
: daily ( x -- y ) 360 / ;

1
unmaintained/taxes/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

1
unmaintained/taxes/summary.txt
View File

@ -1 +0,0 @@
Calculate federal and state tax withholdings

1
unmaintained/taxes/tags.txt
View File

@ -1 +0,0 @@
taxes

145
unmaintained/taxes/taxes.factor
View File

@ -1,145 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math math.intervals
namespaces sequences combinators.lib money math.order ;
IN: taxes
: monthly ( x -- y ) 12 / ;
: semimonthly ( x -- y ) 24 / ;
: biweekly ( x -- y ) 26 / ;
: weekly ( x -- y ) 52 / ;
: daily ( x -- y ) 360 / ;
! Each employee fills out a w4
TUPLE: w4 year allowances married? ;
C: <w4> w4
: allowance ( -- x ) 3500 ; inline
: calculate-w4-allowances ( w4 -- x ) allowances>> allowance * ;
! Withhold: FICA, Medicare, Federal (FICA is social security)
: fica-tax-rate ( -- x ) DECIMAL: .062 ; inline
! Base rate -- income over this rate is not taxed
ERROR: fica-base-unknown ;
: fica-base-rate ( year -- x )
H{
{ 2008 102000 }
{ 2007 97500 }
} at* [ fica-base-unknown ] unless ;
: fica-tax ( salary w4 -- x )
year>> fica-base-rate min fica-tax-rate * ;
! Employer tax only, not withheld
: futa-tax-rate ( -- x ) DECIMAL: .062 ; inline
: futa-base-rate ( -- x ) 7000 ; inline
: futa-tax-offset-credit ( -- x ) DECIMAL: .054 ; inline
: futa-tax ( salary w4 -- x )
drop futa-base-rate min
futa-tax-rate futa-tax-offset-credit -
* ;
! No base rate for medicare; all wages subject
: medicare-tax-rate ( -- x ) DECIMAL: .0145 ; inline
: medicare-tax ( salary w4 -- x ) drop medicare-tax-rate * ;
MIXIN: collector
GENERIC: adjust-allowances ( salary w4 collector -- newsalary )
GENERIC: withholding ( salary w4 collector -- x )
TUPLE: tax-table single married ;
: <tax-table> ( single married class -- obj )
>r tax-table boa r> construct-delegate ;
: tax-bracket-range ( pair -- n ) dup second swap first - ;
: tax-bracket ( tax salary triples -- tax salary )
[ [ tax-bracket-range min ] keep third * + ] 2keep
tax-bracket-range [-] ;
: tax ( salary triples -- x )
0 -rot [ tax-bracket ] each drop ;
: marriage-table ( w4 tax-table -- triples )
swap married?>> [ married>> ] [ single>> ] if ;
: federal-tax ( salary w4 tax-table -- n )
[ adjust-allowances ] 2keep marriage-table tax ;
! http://www.irs.gov/pub/irs-pdf/p15.pdf
! Table 7 ANNUAL Payroll Period
: federal-single ( -- triples )
{
{ 0 2650 DECIMAL: 0 }
{ 2650 10300 DECIMAL: .10 }
{ 10300 33960 DECIMAL: .15 }
{ 33960 79725 DECIMAL: .25 }
{ 79725 166500 DECIMAL: .28 }
{ 166500 359650 DECIMAL: .33 }
{ 359650 1/0. DECIMAL: .35 }
} ;
: federal-married ( -- triples )
{
{ 0 8000 DECIMAL: 0 }
{ 8000 23550 DECIMAL: .10 }
{ 23550 72150 DECIMAL: .15 }
{ 72150 137850 DECIMAL: .25 }
{ 137850 207700 DECIMAL: .28 }
{ 207700 365100 DECIMAL: .33 }
{ 365100 1/0. DECIMAL: .35 }
} ;
TUPLE: federal ;
INSTANCE: federal collector
: <federal> ( -- obj )
federal-single federal-married federal <tax-table> ;
M: federal adjust-allowances ( salary w4 collector -- newsalary )
drop calculate-w4-allowances - ;
M: federal withholding ( salary w4 tax-table -- x )
[ federal-tax ] 3keep drop
[ fica-tax ] 2keep
medicare-tax + + ;
! Minnesota
: minnesota-single ( -- triples )
{
{ 0 1950 DECIMAL: 0 }
{ 1950 23750 DECIMAL: .0535 }
{ 23750 73540 DECIMAL: .0705 }
{ 73540 1/0. DECIMAL: .0785 }
} ;
: minnesota-married ( -- triples )
{
{ 0 7400 DECIMAL: 0 }
{ 7400 39260 DECIMAL: .0535 }
{ 39260 133980 DECIMAL: .0705 }
{ 133980 1/0. DECIMAL: .0785 }
} ;
TUPLE: minnesota ;
INSTANCE: minnesota collector
: <minnesota> ( -- obj )
minnesota-single minnesota-married minnesota <tax-table> ;
M: minnesota adjust-allowances ( salary w4 collector -- newsalary )
drop calculate-w4-allowances - ;
M: minnesota withholding ( salary w4 collector -- x )
[ adjust-allowances ] 2keep marriage-table tax ;
: employer-withhold ( salary w4 collector -- x )
[ withholding ] 3keep
dup federal? [ 3drop ] [ drop <federal> withholding + ] if ;
: net ( salary w4 collector -- x )
>r dupd r> employer-withhold - ;