ln -s Factor.app/Contents/MacOS/factor ./factor
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
- install_name_tool \
- -id @executable_path/../Frameworks/libfreetype.6.dylib \
- Factor.app/Contents/Frameworks/libfreetype.6.dylib
install_name_tool \
-change libfactor.dylib \
@executable_path/../Frameworks/libfactor.dylib \
Factor.app/Contents/MacOS/factor
-
+
factor: $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
} [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
{
class<=-cache class-not-cache classes-intersect-cache
- class-and-cache class-or-cache
+ class-and-cache class-or-cache next-method-quot-cache
} [ H{ } clone ] H{ } map>assoc assoc-union
bootstrap-global set
bootstrap-global emit-userenv ;
{ $values { "x" number } { "duration" duration } }
{ $description "Creates a duration object with the specified number of milliseconds." } ;
-{ years months days hours minutes seconds milliseconds } related-words
+HELP: microseconds
+{ $values { "x" number } { "duration" duration } }
+{ $description "Creates a duration object with the specified number of microseconds." } ;
+
+HELP: nanoseconds
+{ $values { "x" number } { "duration" duration } }
+{ $description "Creates a duration object with the specified number of nanoseconds." } ;
+
+{ years months days hours minutes seconds milliseconds microseconds nanoseconds } related-words
HELP: leap-year?
{ $values { "obj" object } { "?" "a boolean" } }
}
} ;
-{ duration>years duration>months duration>days duration>hours duration>minutes duration>seconds duration>milliseconds } related-words
+HELP: duration>microseconds
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in microseconds." }
+{ $examples
+ { $example "USING: calendar prettyprint ;"
+ "6 seconds duration>microseconds ."
+ "6000000"
+ }
+} ;
+
+HELP: duration>nanoseconds
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in nanoseconds." }
+{ $examples
+ { $example "USING: calendar prettyprint ;"
+ "6 seconds duration>nanoseconds ."
+ "6000000000"
+ }
+} ;
+
+{ duration>years duration>months duration>days duration>hours duration>minutes duration>seconds duration>milliseconds duration>microseconds duration>nanoseconds } related-words
HELP: time-
{ $subsection minutes }
{ $subsection seconds }
{ $subsection milliseconds }
+{ $subsection microseconds }
+{ $subsection nanoseconds }
{ $subsection instant }
"Converting a duration to a number:"
{ $subsection duration>years }
{ $subsection duration>hours }
{ $subsection duration>minutes }
{ $subsection duration>seconds }
-{ $subsection duration>milliseconds } ;
+{ $subsection duration>milliseconds }
+{ $subsection duration>microseconds }
+{ $subsection duration>nanoseconds } ;
ARTICLE: "relative-timestamps" "Relative timestamps"
"In the future:"
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions namespaces sequences
strings system vocabs.loader threads accessors combinators
-locals classes.tuple math.order summary
+locals classes.tuple math.order summary structs
combinators.short-circuit ;
IN: calendar
: minutes ( x -- duration ) instant clone swap >>minute ;
: seconds ( x -- duration ) instant clone swap >>second ;
: milliseconds ( x -- duration ) 1000 / seconds ;
+: microseconds ( x -- duration ) 1000000 / seconds ;
+: nanoseconds ( x -- duration ) 1000000000 / seconds ;
GENERIC: leap-year? ( obj -- ? )
: duration>minutes ( duration -- x ) duration>years minutes-per-year * ;
: duration>seconds ( duration -- x ) duration>years seconds-per-year * ;
: duration>milliseconds ( duration -- x ) duration>seconds 1000 * ;
+: duration>microseconds ( duration -- x ) duration>seconds 1000000 * ;
+: duration>nanoseconds ( duration -- x ) duration>seconds 1000000000 * ;
GENERIC: time- ( time1 time2 -- time3 )
: time-since-midnight ( timestamp -- duration )
dup midnight time- ;
+: timeval>unix-time ( timeval -- timestamp )
+ [ timeval-sec seconds ] [ timeval-usec microseconds ] bi
+ time+ unix-1970 time+ >local-time ;
+
M: timestamp sleep-until timestamp>millis sleep-until ;
M: duration sleep hence sleep-until ;
{ $values { "quot" quotation } }
{ $description "Sets up an autorelease pool, initializes the " { $snippet "NSApplication" } " singleton, and calls the quotation." } ;
+HELP: cocoa-app
+{ $values { "quot" quotation } }
+{ $description "Initializes Cocoa, calls the quotation, and starts the Cocoa event loop." } ;
+
HELP: do-event
{ $values { "app" "an " { $snippet "NSApplication" } } { "?" "a boolean" } }
{ $description "Processes a pending event in the queue, if any, returning a boolean indicating if there was one. Does not block." } ;
{ $error-description "Thrown by the Objective C runtime when an error occurs, for example, sending a message to an object with an unrecognized selector." } ;
ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
+"Utilities:"
{ $subsection NSApp }
-{ $subsection with-autorelease-pool }
-{ $subsection with-cocoa }
{ $subsection do-event }
{ $subsection add-observer }
{ $subsection remove-observer }
-{ $subsection install-delegate } ;
+{ $subsection install-delegate }
+"Combinators:"
+{ $subsection cocoa-app }
+{ $subsection with-autorelease-pool }
+{ $subsection with-cocoa } ;
IN: cocoa.application
ABOUT: "cocoa-application-utils"
FUNCTION: void NSBeep ( ) ;
: with-cocoa ( quot -- )
- [ NSApp drop call ] with-autorelease-pool ;
+ [ NSApp drop call ] with-autorelease-pool ; inline
: next-event ( app -- event )
0 f CFRunLoopDefaultMode 1
: finish-launching ( -- ) NSApp -> finishLaunching ;
+: cocoa-app ( quot -- )
+ [
+ call
+ finish-launching
+ NSApp -> run
+ ] with-cocoa ; inline
+
: install-delegate ( receiver delegate -- )
-> alloc -> init -> setDelegate: ;
{ send super-send POSTPONE: -> POSTPONE: SUPER-> } related-words
+HELP: IMPORT:
+{ $syntax "IMPORT: name" }
+{ $description "Makes an Objective C class available for use." }
+{ $examples
+ { $code "IMPORT: QTMovie" "QTMovie \"My Movie.mov\" <NSString> f -> movieWithFile:error:" }
+} ;
+
ARTICLE: "objc-calling" "Calling Objective C code"
"Before an Objective C class can be used, it must be imported; by default, a small set of common classes are imported automatically, but additional classes can be imported as needed."
-{ $subsection import-objc-class }
+{ $subsection POSTPONE: IMPORT: }
"Every imported Objective C class has as corresponding class word in the " { $vocab-link "cocoa.classes" } " vocabulary. Class words push the class object in the stack, allowing class methods to be invoked."
$nl
"Messages can be sent to classes and instances using a pair of parsing words:"
USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser
core-foundation namespaces assocs hashtables compiler.units
-lexer ;
+lexer init ;
IN: cocoa
: (remember-send) ( selector variable -- )
scan dup remember-super-send parsed \ super-send parsed ;
parsing
+SYMBOL: frameworks
+
+frameworks global [ V{ } clone or ] change-at
+
+[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
+
+: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; parsing
+
+: IMPORT: scan [ ] import-objc-class ; parsing
+
"Compiling Objective C bridge..." print
"cocoa.classes" create-vocab drop
HELP: import-objc-class
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( -- )" } } }
-{ $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." }
-{ $notes "In most cases, the quotation should be " { $link f } "." }
-{ $examples
- { $code "\"QTMovie\" f import-objc-class" "QTMovie \"My Movie.mov\" <NSString> f -> movieWithFile:error:" }
-} ;
+{ $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." } ;
HELP: root-class
{ $values { "class" alien } { "root" alien } }
combinators compiler kernel math namespaces make parser
prettyprint prettyprint.sections quotations sequences strings
words cocoa.runtime io macros memoize debugger
-io.encodings.ascii effects compiler.generator libc libc.private ;
+io.encodings.ascii effects compiler.generator libc libc.private
+parser lexer init core-foundation ;
IN: cocoa.messages
: make-sender ( method function -- quot )
-! Copyright (C) 2003, 2007, 2008 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel combinators sequences arrays classes.tuple accessors colors.hsv ;
-
+USING: kernel accessors ;
IN: colors
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
TUPLE: color ;
TUPLE: rgba < color red green blue alpha ;
-TUPLE: hsva < color hue saturation value alpha ;
-
-TUPLE: gray < color gray alpha ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+C: <rgba> rgba
GENERIC: >rgba ( object -- rgba )
M: rgba >rgba ( rgba -- rgba ) ;
-M: hsva >rgba ( hsva -- rgba )
- { [ hue>> ] [ saturation>> ] [ value>> ] [ alpha>> ] } cleave 4array
- [ hsv>rgb ] [ peek ] bi suffix first4 rgba boa ;
-
-M: gray >rgba ( gray -- rgba ) [ gray>> dup dup ] [ alpha>> ] bi rgba boa ;
-
M: color red>> ( color -- red ) >rgba red>> ;
M: color green>> ( color -- green ) >rgba green>> ;
M: color blue>> ( color -- blue ) >rgba blue>> ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: black T{ rgba f 0.0 0.0 0.0 1.0 } ;
-: blue T{ rgba f 0.0 0.0 1.0 1.0 } ;
-: cyan T{ rgba f 0 0.941 0.941 1 } ;
-: gray T{ rgba f 0.6 0.6 0.6 1.0 } ;
-: green T{ rgba f 0.0 1.0 0.0 1.0 } ;
-: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ;
-: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ;
-: magenta T{ rgba f 0.941 0 0.941 1 } ;
-: orange T{ rgba f 0.941 0.627 0 1 } ;
-: purple T{ rgba f 0.627 0 0.941 1 } ;
-: red T{ rgba f 1.0 0.0 0.0 1.0 } ;
-: white T{ rgba f 1.0 1.0 1.0 1.0 } ;
-: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ;
+: black T{ rgba f 0.0 0.0 0.0 1.0 } ; inline
+: blue T{ rgba f 0.0 0.0 1.0 1.0 } ; inline
+: cyan T{ rgba f 0 0.941 0.941 1 } ; inline
+: gray T{ rgba f 0.6 0.6 0.6 1.0 } ; inline
+: green T{ rgba f 0.0 1.0 0.0 1.0 } ; inline
+: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ; inline
+: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ; inline
+: magenta T{ rgba f 0.941 0 0.941 1 } ; inline
+: orange T{ rgba f 0.941 0.627 0 1 } ; inline
+: purple T{ rgba f 0.627 0 0.941 1 } ; inline
+: red T{ rgba f 1.0 0.0 0.0 1.0 } ; inline
+: white T{ rgba f 1.0 1.0 1.0 1.0 } ; inline
+: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ; inline
--- /dev/null
+! Copyright (C) 2008 Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: colors kernel accessors ;
+IN: colors.gray
+
+TUPLE: gray < color gray alpha ;
+
+C: <gray> gray
+
+M: gray >rgba ( gray -- rgba )
+ [ gray>> dup dup ] [ alpha>> ] bi <rgba> ;
--- /dev/null
+IN: colors.hsv.tests
+USING: accessors kernel colors colors.hsv tools.test math ;
+
+: hsv>rgb ( h s v -- r g b )
+ [ 360 * ] 2dip
+ 1 <hsva> >rgba [ red>> ] [ green>> ] [ blue>> ] tri ;
+
+[ 1/2 1/2 1/2 ] [ 0 0 1/2 hsv>rgb ] unit-test
+
+[ 1/2 1/4 1/4 ] [ 0 1/2 1/2 hsv>rgb ] unit-test
+[ 1/3 2/9 2/9 ] [ 0 1/3 1/3 hsv>rgb ] unit-test
+
+[ 24/125 1/5 4/25 ] [ 1/5 1/5 1/5 hsv>rgb ] unit-test
+[ 29/180 1/6 5/36 ] [ 1/5 1/6 1/6 hsv>rgb ] unit-test
+
+[ 6/25 2/5 38/125 ] [ 2/5 2/5 2/5 hsv>rgb ] unit-test
+[ 8/25 4/5 64/125 ] [ 2/5 3/5 4/5 hsv>rgb ] unit-test
+
+[ 6/25 48/125 3/5 ] [ 3/5 3/5 3/5 hsv>rgb ] unit-test
+[ 0 0 0 ] [ 3/5 1/5 0 hsv>rgb ] unit-test
+
+[ 84/125 4/25 4/5 ] [ 4/5 4/5 4/5 hsv>rgb ] unit-test
+[ 7/15 1/3 1/2 ] [ 4/5 1/3 1/2 hsv>rgb ] unit-test
+
+[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
+[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
-! Copyright (C) 2007 Eduardo Cavazos
+! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel combinators arrays sequences math math.functions ;
-
+USING: colors kernel combinators math math.functions accessors ;
IN: colors.hsv
-<PRIVATE
-
-: H ( hsv -- H ) first ;
-
-: S ( hsv -- S ) second ;
+! h [0,360)
+! s [0,1]
+! v [0,1]
+TUPLE: hsva < color hue saturation value alpha ;
-: V ( hsv -- V ) third ;
+C: <hsva> hsva
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+<PRIVATE
-: Hi ( hsv -- Hi ) H 60 / floor 6 mod ;
+: Hi ( hsv -- Hi ) hue>> 60 / floor 6 mod ; inline
-: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ;
+: f ( hsv -- f ) [ hue>> 60 / ] [ Hi ] bi - ; inline
-: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ;
+: p ( hsv -- p ) [ saturation>> 1 swap - ] [ value>> ] bi * ; inline
-: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ;
+: q ( hsv -- q ) [ [ f ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
-: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ;
+: t ( hsv -- t ) [ [ f 1 swap - ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
PRIVATE>
-! h [0,360)
-! s [0,1]
-! v [0,1]
-
-: hsv>rgb ( hsv -- rgb )
-dup Hi
-{ { 0 [ [ V ] [ t ] [ p ] tri ] }
- { 1 [ [ q ] [ V ] [ p ] tri ] }
- { 2 [ [ p ] [ V ] [ t ] tri ] }
- { 3 [ [ p ] [ q ] [ V ] tri ] }
- { 4 [ [ t ] [ p ] [ V ] tri ] }
- { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;
+M: hsva >rgba ( hsva -- rgba )
+ [
+ dup Hi
+ {
+ { 0 [ [ value>> ] [ t ] [ p ] tri ] }
+ { 1 [ [ q ] [ value>> ] [ p ] tri ] }
+ { 2 [ [ p ] [ value>> ] [ t ] tri ] }
+ { 3 [ [ p ] [ q ] [ value>> ] tri ] }
+ { 4 [ [ t ] [ p ] [ value>> ] tri ] }
+ { 5 [ [ value>> ] [ p ] [ q ] tri ] }
+ } case
+ ] [ alpha>> ] bi <rgba> ;
[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
[ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
+
+! Loop detection problem found by doublec
+SYMBOL: counter
+
+DEFER: loop-bbb
+
+: loop-aaa ( -- )
+ counter inc counter get 2 < [ loop-bbb ] when ; inline recursive
+
+: loop-bbb ( -- )
+ [ loop-aaa ] with-scope ; inline recursive
+
+: loop-ccc ( -- ) loop-bbb ;
+
+[ 0 ] [ 0 counter set loop-ccc counter get ] unit-test
compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
-float-arrays ;
+float-arrays system ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
[ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test
+[ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
+
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
: fold-call ( #call word -- )
[ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ;
-: predicate-output-infos ( info class -- info )
+: predicate-output-infos/literal ( info class -- info )
+ [ literal>> ] dip
+ '[ _ _ instance? <literal-info> ]
+ [ drop object-info ]
+ recover ;
+
+: predicate-output-infos/class ( info class -- info )
[ class>> ] dip {
{ [ 2dup class<= ] [ t <literal-info> ] }
{ [ 2dup classes-intersect? not ] [ f <literal-info> ] }
[ object-info ]
} cond 2nip ;
+: predicate-output-infos ( info class -- info )
+ over literal?>>
+ [ predicate-output-infos/literal ]
+ [ predicate-output-infos/class ]
+ if ;
+
: propagate-predicate ( #call word -- infos )
#! We need to force the caller word to recompile when the class
#! is redefined, since now we're making assumptions but the
[ a' ] build-tree analyze-recursive
\ b' label-is-loop?
] unit-test
+
+DEFER: a''
+
+: b'' ( -- )
+ a'' ; inline recursive
+
+: a'' ( -- )
+ b'' a'' ; inline recursive
+
+[ t ] [
+ [ a'' ] build-tree analyze-recursive
+ \ a'' label-is-not-loop?
+] unit-test
+
+: loop-in-non-loop ( x quot: ( i -- ) -- )
+ over 0 > [
+ [ [ 1 - ] dip loop-in-non-loop ] [ call ] 2bi
+ ] [ 2drop ] if ; inline recursive
+
+[ t ] [
+ [ 10 [ [ drop ] each-integer ] loop-in-non-loop ]
+ build-tree analyze-recursive
+ \ (each-integer) label-is-loop?
+] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs namespaces accessors sequences deques
+USING: kernel assocs arrays namespaces accessors sequences deques
search-deques compiler.tree compiler.tree.combinators ;
IN: compiler.tree.recursive
loop-stack get length swap loop-heights get set-at ;
M: #recursive collect-loop-info*
- nip
[
[
label>>
- [ loop-stack [ swap suffix ] change ]
+ [ swap 2array loop-stack [ swap suffix ] change ]
[ remember-loop-info ]
[ t >>loop? drop ]
tri
[ t swap child>> (collect-loop-info) ] bi
] with-scope ;
-: current-loop-nesting ( label -- labels )
+: current-loop-nesting ( label -- alist )
loop-stack get swap loop-heights get at tail ;
: disqualify-loop ( label -- )
M: #call-recursive collect-loop-info*
label>>
swap [ dup disqualify-loop ] unless
- dup current-loop-nesting [ loop-calls get push-at ] with each ;
+ dup current-loop-nesting
+ [ keys [ loop-calls get push-at ] with each ]
+ [ [ nip not ] assoc-filter keys [ disqualify-loop ] each ]
+ bi ;
M: #if collect-loop-info*
children>> [ (collect-loop-info) ] with each ;
: handle-node-client ( -- )
deserialize
- [ first2 get-process send ] [ stop-server ] if* ;
+ [ first2 get-process send ] [ stop-this-server ] if* ;
: <node-server> ( addrspec -- threaded-server )
<threaded-server>
IN: db
HELP: db
-{ $description "The " { $snippet "db" } " class is the superclass of all other database classes. It stores a " { $snippet "handle" } " to the database as well as insert, update, and delete queries." } ;
+{ $description "The " { $snippet "db" } " class is the superclass of all other database classes. It stores a " { $snippet "handle" } " to the database as well as insert, update, and delete queries." } ;
HELP: new-db
{ $values { "class" class } { "obj" object } }
-{ $description "Creates a new database object from a given class." } ;
-
-HELP: make-db*
-{ $values { "object" object } { "db" object } { "db" object } }
-{ $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ;
-
-HELP: make-db
-{ $values { "object" object } { "class" class } { "db" db } }
-{ $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ;
+{ $description "Creates a new database object from a given class with caches for prepared statements. Does not actually connect to the database until " { $link db-open } " or " { $link with-db } " is called." }
+{ $notes "User-defined databases must call this constructor word instead of " { $link new } "." } ;
HELP: db-open
{ $values { "db" db } { "db" db } }
-{ $description "Opens a database using the configuration data stored in a " { $link db } " tuple." } ;
+{ $description "Opens a database using the configuration data stored in a " { $link db } " tuple. The database object now references a database handle that must be cleaned up. Therefore, it is better to use the " { $link with-db } " combinator than calling this word directly." } ;
HELP: db-close
{ $values { "handle" alien } }
-{ $description "Closes a database using the handle provided." } ;
+{ $description "Closes a database using the handle provided. Use of the " { $link with-db } " combinator is preferred over manually opening and closing databases so that resources are not leaked." } ;
+
+{ db-open db-close with-db } related-words
HELP: dispose-statements
{ $values { "assoc" assoc } }
HELP: statement
{ $description "A " { $snippet "statement" } " stores the information about a statemen, such as the SQL statement text, the in/out parameters, and type information." } ;
-HELP: simple-statement
-{ $description } ;
-
-HELP: prepared-statement
-{ $description } ;
-
HELP: result-set
{ $description "An object encapsulating a raw SQL result object. There are two ways in which a result set can be accessed, but they are specific to the database backend in use."
{ $subsection "db-random-access-result-set" }
{ $subsection "db-sequential-result-set" }
} ;
-HELP: init-result-set
-{ $values
- { "result-set" result-set } }
-{ $description "" } ;
-
HELP: new-result-set
{ $values
{ "query" "a query" } { "handle" alien } { "class" class }
{ "result-set" result-set } }
{ $description "Creates a new " { $link result-set } " object of type " { $snippet "class" } "." } ;
-
HELP: new-statement
{ $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } }
{ $description "Makes a new statement object from the given parameters." } ;
+HELP: bind-statement
+{ $values
+ { "obj" object } { "statement" statement } }
+{ $description "Sets the statement's " { $slot "bind-params" } " and calls " { $link bind-statement* } " to do the database-specific bind. Sets " { $slot "bound?" } " to true if binding succeeds." } ;
+
+HELP: bind-statement*
+{ $values
+ { "statement" statement } }
+{ $description "Does a low-level bind of the SQL statement's tuple parameters if the database requires. Some databases should treat this as a no-op and bind instead when the actual statement is run." } ;
+
HELP: <simple-statement>
{ $values { "string" string } { "in" sequence } { "out" sequence }
{ "statement" statement } }
-{ $description "Makes a new simple statement object from the given parameters." } ;
+{ $description "Makes a new simple statement object from the given parameters.." }
+{ $warning "Using a simple statement can lead to SQL injection attacks in PostgreSQL. The Factor database implementation for SQLite only uses " { $link <prepared-statement> } " as the sole kind of statement; simple statements alias to prepared ones." } ;
HELP: <prepared-statement>
{ $values { "string" string } { "in" sequence } { "out" sequence }
{ "statement" statement } }
-{ $description "Makes a new prepared statement object from the given parameters." } ;
+{ $description "Makes a new prepared statement object from the given parameters. A prepared statement's parameters will be escaped by the database backend to avoid SQL injection attacks. Prepared statements should be preferred over simple statements." } ;
HELP: prepare-statement
{ $values { "statement" statement } }
{ $description "For databases which implement a method on this generic, it does some internal processing to ready the statement for execution." } ;
-HELP: bind-statement*
-{ $values { "statement" statement } }
-{ $description "" } ;
-
HELP: low-level-bind
-{ $values { "statement" statement } }
-{ $description "" } ;
-
-HELP: bind-tuple
-{ $values { "tuple" tuple } { "statement" statement } }
-{ $description "" } ;
+{ $values
+ { "statement" statement } }
+{ $description "For use with prepared statements, methods on this word should bind the datatype in the SQL spec to its identifier in the SQL string. To name bound variables, SQLite uses identifiers in the form of " { $snippet ":name" } ", while PostgreSQL uses increasing numbers beginning with a dollar sign, e.g. " { $snippet "$1" } "." } ;
HELP: query-results
{ $values { "query" object }
{ "result-set" result-set }
}
-{ $description "Returns a " { $link result-set } " object representing the reults of a SQL query." } ;
+{ $description "Returns a " { $link result-set } " object representing the results of a SQL query. See " { $link "db-result-sets" } "." } ;
HELP: #rows
{ $values { "result-set" result-set } { "n" integer } }
{ $values { "result-set" result-set } { "?" "a boolean" } }
{ $description "Returns true if the " { $link result-set } " has more rows to traverse." } ;
-HELP: execute-statement*
-{ $values { "statement" statement } { "type" object } }
-{ $description } ;
-
-HELP: execute-one-statement
-{ $values
- { "statement" null } }
-{ $description "" } ;
-
-HELP: execute-statement
-{ $values { "statement" statement } }
-{ $description "" } ;
-
-
-
-
HELP: begin-transaction
{ $description "Begins a new transaction. User code should make use of the " { $link with-transaction } " combinator." } ;
-HELP: bind-statement
-{ $values
- { "obj" object } { "statement" null } }
-{ $description "" } ;
-
HELP: commit-transaction
{ $description "Commits a transaction. User code should make use of the " { $link with-transaction } " combinator." } ;
-HELP: default-query
-{ $values
- { "query" null }
- { "result-set" null } }
-{ $description "" } ;
-
HELP: in-transaction
{ $description "A variable that is set true when a transaction is in progress." } ;
HELP: query-each
{ $values
- { "statement" null } { "quot" quotation } }
-{ $description "" } ;
+ { "statement" statement } { "quot" quotation } }
+{ $description "A combinator that calls a quotation on a sequence of SQL statements to their results query results." } ;
HELP: query-map
{ $values
- { "statement" null } { "quot" quotation }
+ { "statement" statement } { "quot" quotation }
{ "seq" sequence } }
-{ $description "" } ;
+{ $description "A combinator that maps a sequence of SQL statements to their results query results." } ;
HELP: rollback-transaction
{ $description "Rolls back a transaction; no data is committed to the database. User code should make use of the " { $link with-transaction } " combinator." } ;
HELP: with-db
{ $values
- { "seq" sequence } { "class" class } { "quot" quotation } }
+ { "db" db } { "quot" quotation } }
{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. The database called is based on the " { $snippet "class" } " with the " } ;
HELP: with-transaction
{ $description "" } ;
ARTICLE: "db" "Database library"
+"Accessing a database:"
{ $subsection "db-custom-database-combinators" }
+"Higher-level database help:"
+{ $vocab-subsection "Database types" "db.types" }
+{ $vocab-subsection "High-level tuple/database integration" "db.tuples" }
+"Low-level database help:"
{ $subsection "db-protocol" }
{ $subsection "db-result-sets" }
{ $subsection "db-lowlevel-tutorial" }
-"Higher-level database:"
-{ $vocab-subsection "Database types" "db.types" }
-{ $vocab-subsection "High-level tuple/database integration" "db.tuples" }
-! { $subsection "db-tuples" }
-! { $subsection "db-tuples-protocol" }
-! { $subsection "db-tuples-tutorial" }
"Supported database backends:"
{ $vocab-subsection "SQLite" "db.sqlite" }
-{ $vocab-subsection "PostgreSQL" "db.postgresql" }
-"To add support for another database to Factor:"
-{ $subsection "db-porting-the-library" }
-;
+{ $vocab-subsection "PostgreSQL" "db.postgresql" } ;
ARTICLE: "db-random-access-result-set" "Random access result sets"
"Random-access result sets do not have to be traversed in order. For instance, PostgreSQL's result set object can be accessed as a matrix with i,j coordinates."
{ $subsection row-column-typed } ;
ARTICLE: "db-sequential-result-set" "Sequential result sets"
-"Sequential result sets can be iterated one element after the next. SQLite's result sets offer this method of traversal."
+"Sequential result sets can be iterated one element after the next. SQLite's result sets offer this method of traversal."
$nl
"Databases which work in this way must provide methods for the following traversal words:"
{ $subsection more-rows? }
{ $subsection row-column-typed } ;
ARTICLE: "db-protocol" "Low-level database protocol"
-"The high-level protocol (see " { $vocab-link "db.tuples" } ") uses this low-level protocol for executing statements and queries."
+"The high-level protocol (see " { $vocab-link "db.tuples" } ") uses this low-level protocol for executing statements and queries." $nl
+"Opening a database:"
+{ $subsection db-open }
+"Closing a database:"
+{ $subsection db-close }
+"Creating tatements:"
+{ $subsection <simple-statement> }
+{ $subsection <prepared-statement> }
+"Using statements with the database:"
+{ $subsection prepare-statement }
+{ $subsection bind-statement* }
+{ $subsection low-level-bind }
+"Performing a query:"
+{ $subsection query-results }
+"Handling query results:"
+{ $subsection "db-result-sets" }
;
+! { $subsection bind-tuple }
ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial"
"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "."
-;
-
-ARTICLE: "db-porting-the-library" "Porting the database library"
-"This section is not yet written."
-;
+"Executing a SQL command:"
+{ $subsection sql-command }
+"Executing a query directly:"
+{ $subsection sql-query }
+"Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
+"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
+{ $code <"
+USING: db.sqlite db io.files ;
+: with-book-db ( quot -- )
+ "book.db" temp-file <sqlite-db> swap with-db ;"> }
+"Now let's create the table manually:"
+{ $code <" "create table books
+ (id integer primary key, title text, author text, date_published timestamp,
+ edition integer, cover_price double, condition text)"
+ [ sql-command ] with-book-db" "> }
+"Time to insert some books:"
+{ $code <"
+"insert into books
+ (title, author, date_published, edition, cover_price, condition)
+ values('Factor for Sheeple', 'Mister Stacky Pants', date('now'), 1, 13.37, 'mint')"
+[ sql-command ] with-book-db"> }
+"Now let's select the book:"
+{ $code <"
+"select id, title, cover_price from books;" [ sql-query ] with-book-db "> }
+"Notice that the result of this query is a Factor array containing the database rows as arrays of strings. We would have to convert the " { $snippet "cover_price" } " from a string to a number in order to use it in a calculation." $nl
+"In conclusion, this method of accessing a database is supported, but it is fairly low-level and generally specific to a single database. The " { $vocab-link "db.tuples" } " vocabulary is a good alternative to writing SQL by hand." ;
ARTICLE: "db-custom-database-combinators" "Custom database combinators"
-"Every database library requires some effort on the programmer's part to initialize and open a database. SQLite uses files on your harddisk, so a simple pathname is all the setup required. With PostgreSQL, you log in to a networked server as a user on a specfic port." $nl
+"Every database library requires some effort on the programmer's part to initialize and open a database. SQLite uses files on your harddisk, so a simple pathname is all the setup required. With PostgreSQL, you log in to a networked server as a user on a specfic port." $nl
+
+"Make a " { $snippet "with-" } " combinator to open and close a database so that resources are not leaked." $nl
-"Make a " { $snippet "with-" } " word to open, close, and use your database."
+"SQLite example combinator:"
{ $code <"
USING: db.sqlite db io.files ;
-: with-my-database ( quot -- )
- { "my-database.db" temp-file } sqlite-db rot with-db ;
-"> }
-
-;
+: with-sqlite-db ( quot -- )
+ "my-database.db" temp-file <sqlite-db> swap with-db ;"> }
+
+"PostgreSQL example combinator:"
+{ $code <" USING: db.postgresql db ;
+: with-postgresql-db ( quot -- )
+ <postgresql-db>
+ "localhost" >>host
+ 5432 >>port
+ "erg" >>username
+ "secrets?" >>password
+ "factor-test" >>database
+ swap with-db ;">
+} ;
ABOUT: "db"
\r
{ 1 0 } [ [ drop ] query-each ] must-infer-as\r
{ 1 1 } [ [ ] query-map ] must-infer-as\r
-{ 2 0 } [ [ ] with-db ] must-infer-as\r
+{ 1 0 } [ [ ] with-db ] must-infer-as\r
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations destructors kernel math
namespaces sequences classes.tuple words strings
-tools.walker accessors combinators ;
+tools.walker accessors combinators fry ;
IN: db
TUPLE: db
H{ } clone >>update-statements
H{ } clone >>delete-statements ; inline
-GENERIC: make-db* ( object db -- db )
-
-: make-db ( object class -- db ) new-db make-db* ;
-
GENERIC: db-open ( db -- db )
HOOK: db-close db ( handle -- )
: query-map ( statement quot -- seq )
accumulator [ query-each ] dip { } like ; inline
-: with-db ( seq class quot -- )
- [ make-db db-open db ] dip
- [ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
- inline
+: with-db ( db quot -- )
+ [ db-open db ] dip
+ '[ db get [ drop @ ] with-disposal ] with-variable ; inline
+! Words for working with raw SQL statements
: default-query ( query -- result-set )
query-results [ [ sql-row ] query-map ] with-disposal ;
: sql-query ( sql -- rows )
f f <simple-statement> [ default-query ] with-disposal ;
+: (sql-command) ( string -- )
+ f f <simple-statement> [ execute-statement ] with-disposal ;
+
: sql-command ( sql -- )
- dup string? [
- f f <simple-statement> [ execute-statement ] with-disposal
- ] [
- ! [
- [ sql-command ] each
- ! ] with-transaction
- ] if ;
+ dup string? [ (sql-command) ] [ [ (sql-command) ] each ] if ;
+! Transactions
SYMBOL: in-transaction
+
HOOK: begin-transaction db ( -- )
HOOK: commit-transaction db ( -- )
HOOK: rollback-transaction db ( -- )
\ <db-pool> must-infer
-{ 2 0 } [ [ ] with-db-pool ] must-infer-as
+{ 1 0 } [ [ ] with-db-pool ] must-infer-as
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
[ "pool-test.db" temp-file delete-file ] ignore-errors
-[ ] [ "pool-test.db" temp-file sqlite-db <db-pool> "pool" set ] unit-test
+[ ] [ "pool-test.db" temp-file <sqlite-db> <db-pool> "pool" set ] unit-test
[ ] [ "pool" get expired>> t >>expired drop ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays namespaces sequences continuations
-io.pools db ;
+io.pools db fry ;
IN: db.pools
-TUPLE: db-pool < pool db params ;
+TUPLE: db-pool < pool db ;
-: <db-pool> ( params db -- pool )
+: <db-pool> ( db -- pool )
db-pool <pool>
- swap >>db
- swap >>params ;
+ swap >>db ;
-: with-db-pool ( db params quot -- )
- >r <db-pool> r> with-pool ; inline
+: with-db-pool ( db quot -- )
+ [ <db-pool> ] dip with-pool ; inline
M: db-pool make-connection ( pool -- )
- [ params>> ] [ db>> ] bi make-db db-open ;
+ db>> db-open ;
: with-pooled-db ( pool quot -- )
- [ db swap with-variable ] curry with-pooled-connection ; inline
+ '[ db _ with-variable ] with-pooled-connection ; inline
-! You will need to run 'createdb factor-test' to create the database.
-! Set username and password in the 'connect' word.
-
USING: kernel db.postgresql alien continuations io classes
prettyprint sequences namespaces tools.test db
-db.tuples db.types unicode.case ;
+db.tuples db.types unicode.case accessors ;
IN: db.postgresql.tests
: test-db ( -- postgresql-db )
- { "localhost" "postgres" "foob" "factor-test" } postgresql-db ;
+ <postgresql-db>
+ "localhost" >>host
+ "postgres" >>username
+ "thepasswordistrust" >>password
+ "factor-test" >>database ;
[ ] [ test-db [ ] with-db ] unit-test
: with-dummy-db ( quot -- )
- >r T{ postgresql-db } db r> with-variable ;
+ [ T{ postgresql-db } db ] dip with-variable ;
IN: db.postgresql
TUPLE: postgresql-db < db
- host port pgopts pgtty db user pass ;
+ host port pgopts pgtty database username password ;
+
+: <postgresql-db> ( -- postgresql-db )
+ postgresql-db new-db ;
TUPLE: postgresql-statement < statement ;
TUPLE: postgresql-result-set < result-set ;
-M: postgresql-db make-db* ( seq db -- db )
- >r first4 r>
- swap >>db
- swap >>pass
- swap >>user
- swap >>host ;
-
M: postgresql-db db-open ( db -- db )
dup {
[ host>> ]
[ port>> ]
[ pgopts>> ]
[ pgtty>> ]
- [ db>> ]
- [ user>> ]
- [ pass>> ]
+ [ database>> ]
+ [ username>> ]
+ [ password>> ]
} cleave connect-postgres >>handle ;
M: postgresql-db dispose ( db -- )
M: postgresql-statement prepare-statement ( statement -- )
dup
- >r db get handle>> f r>
+ [ db get handle>> f ] dip
[ sql>> ] [ in-params>> ] bi
length f PQprepare postgresql-error
>>handle drop ;
bind-name% 1, ;
M: postgresql-db bind# ( spec object -- )
- >r bind-name% f swap type>> r> <literal-bind> 1, ;
+ [ bind-name% f swap type>> ] dip
+ <literal-bind> 1, ;
: create-table-sql ( class -- statement )
[
: create-function-sql ( class -- statement )
[
- >r remove-id r>
+ [ remove-id ] dip
"create function add_" 0% dup 0%
"(" 0%
over [ "," 0% ]
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math namespaces make sequences random
strings math.parser math.intervals combinators math.bitwise
-nmake db db.tuples db.types db.sql classes words shuffle arrays
-destructors continuations db.tuples.private ;
+nmake db db.tuples db.types classes words shuffle arrays
+destructors continuations db.tuples.private prettyprint ;
IN: db.queries
GENERIC: where ( specs obj -- )
: sql-props ( class -- columns table )
[ db-columns ] [ db-table ] bi ;
-: query-make ( class quot -- )
+: query-make ( class quot -- statements )
+ #! query, input, outputs, secondary queries
+ over unparse "table" set
[ sql-props ] dip
[ 0 sql-counter rot with-variable ] curry
- { "" { } { } } nmake
- <simple-statement> maybe-make-retryable ; inline
+ { "" { } { } { } } nmake
+ [ <simple-statement> maybe-make-retryable ] dip
+ [ [ 1array ] dip append ] unless-empty ; inline
: where-primary-key% ( specs -- )
" where " 0%
where-clause
] query-make ;
+ERROR: all-slots-ignored class ;
+
M: db <select-by-slots-statement> ( tuple class -- statement )
[
"select " 0%
- over [ ", " 0% ]
+ [ dupd filter-ignores ] dip
+ over empty? [ all-slots-ignored ] when
+ over
+ [ ", " 0% ]
[ dup column-name>> 0% 2, ] interleave
-
" from " 0% 0%
where-clause
] query-make ;
+: splice ( string1 string2 string3 -- string )
+ swap 3append ;
+
: do-group ( tuple groups -- )
- [
- ", " join " group by " swap 3append
- ] curry change-sql drop ;
+ [ ", " join " group by " splice ] curry change-sql drop ;
: do-order ( tuple order -- )
- [
- ", " join " order by " swap 3append
- ] curry change-sql drop ;
+ [ ", " join " order by " splice ] curry change-sql drop ;
: do-offset ( tuple n -- )
- [
- number>string " offset " swap 3append
- ] curry change-sql drop ;
+ [ number>string " offset " splice ] curry change-sql drop ;
: do-limit ( tuple n -- )
- [
- number>string " limit " swap 3append
- ] curry change-sql drop ;
+ [ number>string " limit " splice ] curry change-sql drop ;
: make-query* ( tuple query -- tuple' )
dupd
! select ID, NAME, SCORE from EXAM limit 1 offset 3
-: select-tuples* ( tuple -- statement )
- dup
- [
- select 0,
- dup class db-columns [ ", " 0, ]
- [ dup column-name>> 0, 2, ] interleave
- from 0,
- class name>> 0,
- ] { { } { } { } } nmake
- >r >r parse-sql 4drop r> r>
- <simple-statement> maybe-make-retryable do-select ;
-
M: db <count-statement> ( query -- statement )
[ tuple>> dup class ] keep
[ [ "select count(*) from " 0% 0% where-clause ] query-make ]
+++ /dev/null
-USING: kernel namespaces db.sql sequences math ;
-IN: db.sql.tests
-
-! TUPLE: person name age ;
-: insert-1
- { insert
- {
- { table "person" }
- { columns "name" "age" }
- { values "erg" 26 }
- }
- } ;
-
-: update-1
- { update "person"
- { set { "name" "erg" }
- { "age" 6 } }
- { where { "age" 6 } }
- } ;
-
-: select-1
- { select
- { columns
- "branchno"
- { count "staffno" as "mycount" }
- { sum "salary" as "mysum" } }
- { from "staff" "lol" }
- { where
- { "salary" > all
- { select
- { columns "salary" }
- { from "staff" }
- { where { "branchno" = "b003" } }
- }
- }
- { "branchno" > 3 } }
- { group-by "branchno" "lol2" }
- { having { count "staffno" > 1 } }
- { order-by "branchno" }
- { offset 40 }
- { limit 20 }
- } ;
+++ /dev/null
-USING: kernel parser quotations classes.tuple words math.order
-nmake namespaces sequences arrays combinators
-prettyprint strings math.parser math symbols db ;
-IN: db.sql
-
-SYMBOLS: insert update delete select distinct columns from as
-where group-by having order-by limit offset is-null desc all
-any count avg table values ;
-
-: input-spec, ( obj -- ) 1, ;
-: output-spec, ( obj -- ) 2, ;
-: input, ( obj -- ) 3, ;
-: output, ( obj -- ) 4, ;
-
-DEFER: sql%
-
-: (sql-interleave) ( seq sep -- )
- [ sql% ] curry [ sql% ] interleave ;
-
-: sql-interleave ( seq str sep -- )
- swap sql% (sql-interleave) ;
-
-: sql-function, ( seq function -- )
- sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
-
-: sql-where, ( seq -- )
- [
- [ second 0, ]
- [ first 0, ]
- [ third 1, \ ? 0, ] tri
- ] each ;
-
-HOOK: sql-create db ( object -- )
-M: db sql-create ( object -- )
- drop
- "create table" sql% ;
-
-HOOK: sql-drop db ( object -- )
-M: db sql-drop ( object -- )
- drop
- "drop table" sql% ;
-
-HOOK: sql-insert db ( object -- )
-M: db sql-insert ( object -- )
- drop
- "insert into" sql% ;
-
-HOOK: sql-update db ( object -- )
-M: db sql-update ( object -- )
- drop
- "update" sql% ;
-
-HOOK: sql-delete db ( object -- )
-M: db sql-delete ( object -- )
- drop
- "delete" sql% ;
-
-HOOK: sql-select db ( object -- )
-M: db sql-select ( object -- )
- "select" sql% "," (sql-interleave) ;
-
-HOOK: sql-columns db ( object -- )
-M: db sql-columns ( object -- )
- "," (sql-interleave) ;
-
-HOOK: sql-from db ( object -- )
-M: db sql-from ( object -- )
- "from" "," sql-interleave ;
-
-HOOK: sql-where db ( object -- )
-M: db sql-where ( object -- )
- "where" 0, sql-where, ;
-
-HOOK: sql-group-by db ( object -- )
-M: db sql-group-by ( object -- )
- "group by" "," sql-interleave ;
-
-HOOK: sql-having db ( object -- )
-M: db sql-having ( object -- )
- "having" "," sql-interleave ;
-
-HOOK: sql-order-by db ( object -- )
-M: db sql-order-by ( object -- )
- "order by" "," sql-interleave ;
-
-HOOK: sql-offset db ( object -- )
-M: db sql-offset ( object -- )
- "offset" sql% sql% ;
-
-HOOK: sql-limit db ( object -- )
-M: db sql-limit ( object -- )
- "limit" sql% sql% ;
-
-! GENERIC: sql-subselect db ( object -- )
-! M: db sql-subselectselect ( object -- )
- ! "(select" sql% sql% ")" sql% ;
-
-HOOK: sql-table db ( object -- )
-M: db sql-table ( object -- )
- sql% ;
-
-HOOK: sql-set db ( object -- )
-M: db sql-set ( object -- )
- "set" "," sql-interleave ;
-
-HOOK: sql-values db ( object -- )
-M: db sql-values ( object -- )
- "values(" sql% "," (sql-interleave) ")" sql% ;
-
-HOOK: sql-count db ( object -- )
-M: db sql-count ( object -- )
- "count" sql-function, ;
-
-HOOK: sql-sum db ( object -- )
-M: db sql-sum ( object -- )
- "sum" sql-function, ;
-
-HOOK: sql-avg db ( object -- )
-M: db sql-avg ( object -- )
- "avg" sql-function, ;
-
-HOOK: sql-min db ( object -- )
-M: db sql-min ( object -- )
- "min" sql-function, ;
-
-HOOK: sql-max db ( object -- )
-M: db sql-max ( object -- )
- "max" sql-function, ;
-
-: sql-array% ( array -- )
- unclip
- {
- { \ create [ sql-create ] }
- { \ drop [ sql-drop ] }
- { \ insert [ sql-insert ] }
- { \ update [ sql-update ] }
- { \ delete [ sql-delete ] }
- { \ select [ sql-select ] }
- { \ columns [ sql-columns ] }
- { \ from [ sql-from ] }
- { \ where [ sql-where ] }
- { \ group-by [ sql-group-by ] }
- { \ having [ sql-having ] }
- { \ order-by [ sql-order-by ] }
- { \ offset [ sql-offset ] }
- { \ limit [ sql-limit ] }
- { \ table [ sql-table ] }
- { \ set [ sql-set ] }
- { \ values [ sql-values ] }
- { \ count [ sql-count ] }
- { \ sum [ sql-sum ] }
- { \ avg [ sql-avg ] }
- { \ min [ sql-min ] }
- { \ max [ sql-max ] }
- [ sql% [ sql% ] each ]
- } case ;
-
-ERROR: no-sql-match ;
-: sql% ( obj -- )
- {
- { [ dup string? ] [ 0, ] }
- { [ dup array? ] [ sql-array% ] }
- { [ dup number? ] [ number>string sql% ] }
- { [ dup symbol? ] [ unparse sql% ] }
- { [ dup word? ] [ unparse sql% ] }
- { [ dup quotation? ] [ call ] }
- [ no-sql-match ]
- } cond ;
-
-: parse-sql ( obj -- sql in-spec out-spec in out )
- [ [ sql% ] each ] { { } { } { } } nmake
- [ " " join ] 2dip ;
IN: db.sqlite.tests
: db-path "test.db" temp-file ;
-: test.db db-path sqlite-db ;
+: test.db db-path <sqlite-db> ;
[ ] [ [ db-path delete-file ] ignore-errors ] unit-test
sequences strings classes.tuple alien.c-types continuations
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
math.intervals io nmake accessors vectors math.ranges random
-math.bitwise db.queries destructors db.tuples.private ;
+math.bitwise db.queries destructors db.tuples.private interpolate
+io.streams.string multiline make ;
IN: db.sqlite
TUPLE: sqlite-db < db path ;
-M: sqlite-db make-db* ( path db -- db )
- swap >>path ;
+: <sqlite-db> ( path -- sqlite-db )
+ sqlite-db new-db
+ swap >>path ;
M: sqlite-db db-open ( db -- db )
dup path>> sqlite-open >>handle ;
handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
M: sqlite-statement low-level-bind ( statement -- )
- [ bind-params>> ] [ handle>> ] bi
- [ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ;
+ [ handle>> ] [ bind-params>> ] bi
+ [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare
tuck
[ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
rot set-slot-named
- >r [ key>> ] [ type>> ] bi r> swap <sqlite-low-level-binding> ;
+ [ [ key>> ] [ type>> ] bi ] dip
+ swap <sqlite-low-level-binding> ;
M: sqlite-statement bind-tuple ( tuple statement -- )
[
M: sqlite-result-set row-column-typed ( result-set n -- obj )
dup pick out-params>> nth type>>
- >r >r handle>> r> r> sqlite-column-typed ;
+ [ handle>> ] 2dip sqlite-column-typed ;
M: sqlite-result-set advance-row ( result-set -- )
dup handle>> sqlite-next >>has-more? drop ;
dupd
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
- dup column-name>> 0%
+ dup "sql-spec" set
+ dup column-name>> [ "table-id" set ] [ 0% ] bi
" " 0%
dup type>> lookup-create-type 0%
modifiers 0%
<insert-db-assigned-statement> ;
M: sqlite-db bind# ( spec obj -- )
- >r
- [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
- [ type>> ] bi
- r> <literal-bind> 1, ;
+ [
+ [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
+ [ type>> ] bi
+ ] dip <literal-bind> 1, ;
M: sqlite-db bind% ( spec -- )
dup 1, column-name>> ":" prepend 0% ;
{ random-generator { f f f } }
} ;
+: insert-trigger ( -- string )
+ [
+ <"
+ CREATE TRIGGER fki_${table}_${foreign-table}_id
+ BEFORE INSERT ON ${table}
+ FOR EACH ROW BEGIN
+ SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+ WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+ END;
+ "> interpolate
+ ] with-string-writer ;
+
+: insert-trigger-not-null ( -- string )
+ [
+ <"
+ CREATE TRIGGER fki_${table}_${foreign-table}_id
+ BEFORE INSERT ON ${table}
+ FOR EACH ROW BEGIN
+ SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+ WHERE NEW.${foreign-table-id} IS NOT NULL
+ AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+ END;
+ "> interpolate
+ ] with-string-writer ;
+
+: update-trigger ( -- string )
+ [
+ <"
+ CREATE TRIGGER fku_${table}_${foreign-table}_id
+ BEFORE UPDATE ON ${table}
+ FOR EACH ROW BEGIN
+ SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+ WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+ END;
+ "> interpolate
+ ] with-string-writer ;
+
+: update-trigger-not-null ( -- string )
+ [
+ <"
+ CREATE TRIGGER fku_${table}_${foreign-table}_id
+ BEFORE UPDATE ON ${table}
+ FOR EACH ROW BEGIN
+ SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+ WHERE NEW.${foreign-table-id} IS NOT NULL
+ AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+ END;
+ "> interpolate
+ ] with-string-writer ;
+
+: delete-trigger-restrict ( -- string )
+ [
+ <"
+ CREATE TRIGGER fkd_${table}_${foreign-table}_id
+ BEFORE DELETE ON ${foreign-table}
+ FOR EACH ROW BEGIN
+ SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
+ WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
+ END;
+ "> interpolate
+ ] with-string-writer ;
+
+: delete-trigger-cascade ( -- string )
+ [
+ <"
+ CREATE TRIGGER fkd_${table}_${foreign-table}_id
+ BEFORE DELETE ON ${foreign-table}
+ FOR EACH ROW BEGIN
+ DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id};
+ END;
+ "> interpolate
+ ] with-string-writer ;
+
+: can-be-null? ( -- ? )
+ "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ;
+
+: delete-cascade? ( -- ? )
+ "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;
+
+: sqlite-trigger, ( string -- )
+ { } { } <simple-statement> 3, ;
+
+: create-sqlite-triggers ( -- )
+ can-be-null? [
+ insert-trigger sqlite-trigger,
+ update-trigger sqlite-trigger,
+ ] [
+ insert-trigger-not-null sqlite-trigger,
+ update-trigger-not-null sqlite-trigger,
+ ] if
+ delete-cascade? [
+ delete-trigger-cascade sqlite-trigger,
+ ] [
+ delete-trigger-restrict sqlite-trigger,
+ ] if ;
+
M: sqlite-db compound ( string seq -- new-string )
over {
{ "default" [ first number>string join-space ] }
- { "references" [ >reference-string ] }
+ { "references" [
+ [ >reference-string ] keep
+ first2 [ "foreign-table" set ]
+ [ "foreign-table-id" set ] bi*
+ create-sqlite-triggers
+ ] }
[ 2drop ]
} case ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes help.markup help.syntax io.streams.string kernel
-quotations sequences strings multiline math db.types ;
+quotations sequences strings multiline math db.types db ;
IN: db.tuples
+HELP: create-sql-statement
+{ $values
+ { "class" class }
+ { "object" object } }
+{ $description "Generates the SQL code for creating a table for a given class." } ;
+
+HELP: drop-sql-statement
+{ $values
+ { "class" class }
+ { "object" object } }
+{ $description "Generates the SQL code for dropping a table for a given class." } ;
+
+HELP: insert-tuple-set-key
+{ $values
+ { "tuple" tuple } { "statement" statement } }
+{ $description "Inserts a tuple and sets its primary key in one word. This is necessary for some databases." } ;
+
+HELP: <count-statement>
+{ $values
+ { "query" query }
+ { "statement" statement } }
+{ $description "A database-specific hook for generating the SQL for a count statement." } ;
+
+HELP: <delete-tuples-statement>
+{ $values
+ { "tuple" tuple } { "class" class }
+ { "object" object } }
+{ $description "A database-specific hook for generating the SQL for an delete statement." } ;
+
+HELP: <insert-db-assigned-statement>
+{ $values
+ { "class" class }
+ { "object" object } }
+{ $description "A database-specific hook for generating the SQL for an insert statement with a database-assigned primary key." } ;
+
+HELP: <insert-user-assigned-statement>
+{ $values
+ { "class" class }
+ { "object" object } }
+{ $description "A database-specific hook for generating the SQL for an insert statement with a user-assigned primary key." } ;
+
+HELP: <select-by-slots-statement>
+{ $values
+ { "tuple" tuple } { "class" class }
+ { "tuple" tuple } }
+{ $description "A database-specific hook for generating the SQL for a select statement." } ;
+
+HELP: <update-tuple-statement>
+{ $values
+ { "class" class }
+ { "object" object } }
+{ $description "A database-specific hook for generating the SQL for an update statement." } ;
+
+
HELP: define-persistent
{ $values
{ "class" class } { "table" string } { "columns" "an array of slot specifiers" } }
{ $subsection count-tuples } ;
ARTICLE: "db-tuples-protocol" "Tuple database protocol"
-;
+"Creating a table:"
+{ $subsection create-sql-statement }
+"Dropping a table:"
+{ $subsection drop-sql-statement }
+"Inserting a tuple:"
+{ $subsection <insert-db-assigned-statement> }
+{ $subsection <insert-user-assigned-statement> }
+"Updating a tuple:"
+{ $subsection <update-tuple-statement> }
+"Deleting tuples:"
+{ $subsection <delete-tuples-statement> }
+"Selecting tuples:"
+{ $subsection <select-by-slots-statement> }
+"Counting tuples:"
+{ $subsection <count-statement> } ;
ARTICLE: "db-tuples-tutorial" "Tuple database tutorial"
"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl
{ $list
"Make a new tuple to represent your data"
{ "Map the Factor types to the database types with " { $link define-persistent } }
- { "Make a " { $link "db-custom-database-combinators" } " to open your database and run a " { $snippet "quotation" } }
+ { "Make a custom database combinator (see" { $link "db-custom-database-combinators" } ") to open your database and run a " { $link quotation } }
{ "Create a table with " { $link create-table } ", " { $link ensure-table } ", or " { $link recreate-table } }
{ "Start making and storing objects with " { $link insert-tuple } ", " { $link update-tuple } ", " { $link delete-tuples } ", and " { $link select-tuples } }
} ;
math.ranges strings urls fry db.tuples.private ;
IN: db.tuples.tests
+: sqlite-db ( -- sqlite-db )
+ "tuples-test.db" temp-file <sqlite-db> ;
+
: test-sqlite ( quot -- )
- [ ] swap '[
- "tuples-test.db" temp-file sqlite-db _ with-db
- ] unit-test ;
+ '[
+ [ ] [
+ "tuples-test.db" temp-file <sqlite-db> _ with-db
+ ] unit-test
+ ] call ; inline
+
+: postgresql-db ( -- postgresql-db )
+ <postgresql-db>
+ "localhost" >>host
+ "postgres" >>username
+ "thepasswordistrust" >>password
+ "factor-test" >>database ;
: test-postgresql ( quot -- )
- [ ] swap '[
- { "localhost" "postgres" "foob" "factor-test" }
- postgresql-db _ with-db
- ] unit-test ;
+ '[
+ [ ] [ postgresql-db _ with-db ] unit-test
+ ] call ; inline
+
+! These words leak resources, but are useful for interactivel testing
+: sqlite-test-db ( -- )
+ sqlite-db db-open db set ;
+
+: postgresql-test-db ( -- )
+ postgresql-db db-open db set ;
TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob url ;
T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ;
+
TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ;
-: db-assigned-paste-schema ( -- )
- paste "PASTE"
+paste "PASTE"
+{
+ { "n" "ID" +db-assigned-id+ }
+ { "summary" "SUMMARY" TEXT }
+ { "author" "AUTHOR" TEXT }
+ { "channel" "CHANNEL" TEXT }
+ { "mode" "MODE" TEXT }
+ { "contents" "CONTENTS" TEXT }
+ { "timestamp" "DATE" TIMESTAMP }
+ { "annotations" { +has-many+ annotation } }
+} define-persistent
+
+: annotation-schema-foreign-key ( -- )
+ annotation "ANNOTATION"
{
{ "n" "ID" +db-assigned-id+ }
+ { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
{ "summary" "SUMMARY" TEXT }
{ "author" "AUTHOR" TEXT }
- { "channel" "CHANNEL" TEXT }
{ "mode" "MODE" TEXT }
{ "contents" "CONTENTS" TEXT }
- { "timestamp" "DATE" TIMESTAMP }
- { "annotations" { +has-many+ annotation } }
- } define-persistent
+ } define-persistent ;
+
+: annotation-schema-foreign-key-not-null ( -- )
+ annotation "ANNOTATION"
+ {
+ { "n" "ID" +db-assigned-id+ }
+ { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } +not-null+ }
+ { "summary" "SUMMARY" TEXT }
+ { "author" "AUTHOR" TEXT }
+ { "mode" "MODE" TEXT }
+ { "contents" "CONTENTS" TEXT }
+ } define-persistent ;
+: annotation-schema-cascade ( -- )
annotation "ANNOTATION"
{
{ "n" "ID" +db-assigned-id+ }
- { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" }
+ { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" }
+on-delete+ +cascade+ }
{ "summary" "SUMMARY" TEXT }
{ "author" "AUTHOR" TEXT }
{ "contents" "CONTENTS" TEXT }
} define-persistent ;
+: annotation-schema-restrict ( -- )
+ annotation "ANNOTATION"
+ {
+ { "n" "ID" +db-assigned-id+ }
+ { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } }
+ { "summary" "SUMMARY" TEXT }
+ { "author" "AUTHOR" TEXT }
+ { "mode" "MODE" TEXT }
+ { "contents" "CONTENTS" TEXT }
+ } define-persistent ;
+
: test-paste-schema ( -- )
- [ ] [ db-assigned-paste-schema ] unit-test
[ ] [ paste ensure-table ] unit-test
[ ] [ annotation ensure-table ] unit-test
[ ] [ annotation drop-table ] unit-test
"erg" >>author
"annotation contents" >>contents
insert-tuple
- ] unit-test
-
- [ ] [
- ] unit-test
- ;
+ ] unit-test ;
-[ test-paste-schema ] test-sqlite
-[ test-paste-schema ] test-postgresql
+: test-foreign-key ( -- )
+ [ ] [ annotation-schema-foreign-key ] unit-test
+ test-paste-schema
+ [ paste new 1 >>n delete-tuples ] must-fail ;
+
+: test-foreign-key-not-null ( -- )
+ [ ] [ annotation-schema-foreign-key-not-null ] unit-test
+ test-paste-schema
+ [ paste new 1 >>n delete-tuples ] must-fail ;
+
+: test-cascade ( -- )
+ [ ] [ annotation-schema-cascade ] unit-test
+ test-paste-schema
+ [ ] [ paste new 1 >>n delete-tuples ] unit-test
+ [ 0 ] [ paste new select-tuples length ] unit-test ;
+
+: test-restrict ( -- )
+ [ ] [ annotation-schema-restrict ] unit-test
+ test-paste-schema
+ [ paste new 1 >>n delete-tuples ] must-fail ;
+
+[ test-foreign-key ] test-sqlite
+[ test-foreign-key-not-null ] test-sqlite
+[ test-cascade ] test-sqlite
+[ test-restrict ] test-sqlite
+
+[ test-foreign-key ] test-postgresql
+[ test-foreign-key-not-null ] test-postgresql
+[ test-cascade ] test-postgresql
+[ test-restrict ] test-postgresql
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
[ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
[ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
+ [ 4 ]
+ [ T{ exam { name IGNORE } { score IGNORE } } select-tuples length ] unit-test
+
+ [ f ]
+ [ T{ exam { name IGNORE } { score IGNORE } } select-tuples first score>> ] unit-test
+
+ [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] [ class>> "EXAM" = ] must-fail-with
+
[
{
T{ exam f 3 "Kenny" 60 }
[ test-compound-primary-key ] test-sqlite
[ test-compound-primary-key ] test-postgresql
-
-: sqlite-test-db ( -- )
- "tuples-test.db" temp-file sqlite-db make-db db-open db set ;
-
-: postgresql-test-db ( -- )
- { "localhost" "postgres" "foob" "factor-test" } postgresql-db
- make-db db-open db set ;
destructors mirrors sets db.types ;
IN: db.tuples
-<PRIVATE
-! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- object )
HOOK: drop-sql-statement db ( class -- object )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
HOOK: <count-statement> db ( query -- statement )
HOOK: query>statement db ( query -- statement )
-
HOOK: insert-tuple-set-key db ( tuple statement -- )
+<PRIVATE
+
SYMBOL: sql-counter
+
: next-sql-counter ( -- str )
sql-counter [ inc ] [ get ] bi number>string ;
: do-count ( exemplar-tuple statement -- tuples )
[ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ;
-PRIVATE>
+PRIVATE>
! High level
ERROR: no-slots-named class seq ;
{ $description "" } ;
HELP: +db-assigned-id+
-{ $description "The database assigns a primary key to the object. The primary key is most likely a big integer, but is database-dependent." } ;
+{ $description "The database assigns a primary key to the object. The primary key is most likely a big integer, but is database-dependent." } ;
HELP: +default+
{ $description "" } ;
{ $description "" } ;
HELP: +random-id+
-{ $description "Factor chooses a random number and tries to insert the tuple into the database with this number as its primary key. The default number of retries to find a unique random number is 10, though in practice it will almost certainly succeed on the first try." } ;
+{ $description "Factor chooses a random number and tries to insert the tuple into the database with this number as its primary key. The default number of retries to find a unique random number is 10, though in practice it will almost certainly succeed on the first try." } ;
HELP: +serial+
{ $description "" } ;
{ $description "" } ;
HELP: +user-assigned-id+
-{ $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ;
+{ $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ;
HELP: <generator-bind>
{ $description "" } ;
{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ;
HELP: BLOB
-{ $description "A serialized Factor object. The database library automatically serializes the object for a SQL insert or update and deserializes it on a tuple query." } ;
+{ $description "A byte array." } ;
HELP: BOOLEAN
{ $description "Either true or false." } ;
{ $description "A date and a time." } ;
HELP: DOUBLE
-{ $description "Corresponds to Factor's 64bit floating-point numbers." } ;
+{ $description "Corresponds to Factor's 64-bit floating-point numbers." } ;
HELP: FACTOR-BLOB
{ $description "A serialized Factor object." } ;
{ $description "The SQL null type." } ;
HELP: REAL
-{ $description "" } ;
+{ $description "A real number of unlimited precision. May not be supported on all databases." } ;
HELP: SIGNED-BIG-INTEGER
-{ $description "For portability, if a number is known to be 64bit and signed, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
+{ $description "For portability, if a number is known to be 64bit and signed, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
HELP: TEXT
-{ $description "" } ;
+{ $description "Stores a string that is longer than a " { $link VARCHAR } ". SQLite uses this type for strings; it does not handle " { $link VARCHAR } " strings." } ;
HELP: TIME
-{ $description "" } ;
+{ $description "A timestamp without a date component." } ;
HELP: TIMESTAMP
{ $description "A Factor timestamp." } ;
HELP: UNSIGNED-BIG-INTEGER
-{ $description "For portability, if a number is known to be 64bit, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
+{ $description "For portability, if a number is known to be 64bit, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ;
{ INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER } related-words
HELP: URL
-{ $description "A Factor " { $link "urls" } " object." } ;
+{ $description "A Factor " { $link "urls" } " object." } ;
HELP: VARCHAR
-{ $description "The SQL varchar type. This type can take an integer as an argument." } ;
+{ $description "The SQL varchar type. This type can take an integer as an argument." }
+{ $examples { $unchecked-example "{ VARCHAR 256 }" "" } } ;
HELP: user-assigned-id-spec?
{ $values
{ $subsection DATETIME }
{ $subsection TIME }
{ $subsection TIMESTAMP }
-"Arbitrary Factor objects:"
+"Factor byte-arrays:"
{ $subsection BLOB }
+"Arbitrary Factor objects:"
{ $subsection FACTOR-BLOB }
"Factor URLs:"
{ $subsection URL } ;
+foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+
+set-default+ ;
+SYMBOL: IGNORE
+
+: filter-ignores ( tuple specs -- specs' )
+ [ <mirror> [ nip IGNORE = ] assoc-filter keys ] dip
+ [ slot-name>> swap member? not ] with filter ;
+
+ERROR: no-slot ;
+
: offset-of-slot ( string tuple -- n )
class superclasses [ "slots" word-prop ] map concat
- slot-named offset>> ;
+ slot-named dup [ no-slot ] unless offset>> ;
: get-slot-named ( name tuple -- value )
tuck offset-of-slot slot ;
DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
FACTOR-BLOB NULL URL ;
-: spec>tuple ( class spec -- tuple )
- 3 f pad-right
- [ first3 ] keep 3 tail
+: <sql-spec> ( class slot-name column-name type modifiers -- sql-spec )
sql-spec new
swap >>modifiers
swap >>type
swap >>column-name
swap >>slot-name
swap >>class
- dup normalize-spec ;
+ dup normalize-spec ;
+
+: spec>tuple ( class spec -- tuple )
+ 3 f pad-right [ first3 ] keep 3 tail <sql-spec> ;
: number>string* ( n/string -- string )
dup number? [ number>string ] when ;
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
-
: ?at ( obj assoc -- value/obj ? )
dupd at* [ [ nip ] [ drop ] if ] keep ;
HOOK: bind% db ( spec -- )
HOOK: bind# db ( spec obj -- )
+ERROR: no-column column ;
+
: >reference-string ( string pair -- string )
first2
[ [ unparse join-space ] [ db-columns ] bi ] dip
- swap [ slot-name>> = ] with find nip
+ swap [ column-name>> = ] with find nip
+ [ no-column ] unless*
column-name>> paren append ;
M: string error. print ;
+: :error ( -- )
+ error get error. ;
+
: :s ( -- )
error-continuation get data>> stack. ;
[ "\n<ul><li> a</li>\n</ul><hr/>" ]
[ "\n- a\n___" convert-farkup ] unit-test
+
+[ "<p>hello_world how are you today?\n<ul><li> hello_world how are you today?</li></ul></p>" ]
+[ "hello_world how are you today?\n- hello_world how are you today?" convert-farkup ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators html.elements io
-io.streams.string kernel math memoize namespaces peg peg.ebnf
+io.streams.string kernel math namespaces peg peg.ebnf
sequences sequences.deep strings xml.entities
-vectors splitting xmode.code2html urls ;
+vectors splitting xmode.code2html urls.encoding ;
IN: farkup
SYMBOL: relative-link-prefix
SYMBOL: disable-images?
SYMBOL: link-no-follow?
+SYMBOL: line-breaks?
TUPLE: heading1 child ;
TUPLE: heading2 child ;
TUPLE: image href text ;
TUPLE: code mode string ;
TUPLE: line ;
+TUPLE: line-break ;
: absolute-url? ( string -- ? )
{ "http://" "https://" "ftp://" } [ head? ] with contains? ;
text = (!(nl | code | heading | inline-delimiter | table ).)+
=> [[ >string ]]
-paragraph-nl-item = nl (list | line)?
+paragraph-nl-item = nl list
+ | nl line
+ | nl => [[ line-breaks? get [ drop line-break new ] when ]]
paragraph-item = (table | code | text | inline-tag | inline-delimiter)+
paragraph = ((paragraph-item paragraph-nl-item)+ nl+ => [[ first ]]
| (paragraph-item paragraph-nl-item)+ paragraph-item?
=> [[ paragraph boa ]]
-list-item = (cell | inline-tag)*
+list-item = (cell | inline-tag | inline-delimiter)*
ordered-list-item = '#' list-item
=> [[ second list-item boa ]]
M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ;
M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ;
M: line (write-farkup) drop <hr/> ;
+M: line-break (write-farkup) drop <br/> nl ;
M: table-row (write-farkup) ( obj -- )
child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;
\r
: revalidate-url ( -- url/f )\r
revalidate-url-key param\r
- dup [ >url [ same-host? ] keep and ] when ;\r
+ dup [ >url ensure-port [ same-host? ] keep and ] when ;\r
\r
: validation-failed ( -- * )\r
post-request? revalidate-url and [\r
state-classes ensure-tables
user ensure-table ;
-: <alloy> ( responder db params -- responder' )
- [ [ init-furnace-tables ] with-db ]
+: <alloy> ( responder db -- responder' )
+ [ [ init-furnace-tables ] with-db ] keep
[
- [
- <asides>
- <conversations>
- <sessions>
- ] 2dip
- <db-persistence>
- <check-form-submissions>
- ] 2bi ;
+ <asides>
+ <conversations>
+ <sessions>
+ ] dip
+ <db-persistence>
+ <check-form-submissions> ;
-: start-expiring ( db params -- )
+: start-expiring ( db -- )
'[
- _ _ [ state-classes [ expire-state ] each ] with-db
+ _ [ state-classes [ expire-state ] each ] with-db
] 5 minutes every drop ;
\r
[ "auth-test.db" temp-file delete-file ] ignore-errors\r
\r
-"auth-test.db" temp-file sqlite-db [\r
+"auth-test.db" temp-file <sqlite-db> [\r
\r
user ensure-table\r
\r
[ ] >>init ;
: wrap-boilerplate? ( response -- ? )
- {
- [ code>> { [ 200 = ] [ 400 499 between? ] } 1|| ]
- [ content-type>> "text/html" = ]
- } 1&& ;
+ { [ code>> 200 = ] [ content-type>> "text/html" = ] } 1&& ;
M:: boilerplate call-responder* ( path responder -- )
begin-form
path responder call-next-method
responder init>> call
- dup content-type>> "text/html" = [
+ dup wrap-boilerplate? [
clone [| body |
[
body
attrs>> '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
: a-start-tag ( tag -- )
- [ compile-link-attrs ] [ compile-a-url ] bi
- [ <a =href a> ] [code] ;
+ [ <a ] [code]
+ [ non-chloe-attrs-only compile-attrs ]
+ [ compile-link-attrs ]
+ [ compile-a-url ]
+ tri
+ [ =href a> ] [code] ;
: a-end-tag ( tag -- )
drop [ </a> ] [code] ;
[ a-start-tag ] [ compile-children ] [ a-end-tag ] tri
] compile-with-scope ;
+CHLOE: base
+ compile-a-url [ <base =href base/> ] [code] ;
+
: compile-hidden-form-fields ( for -- )
'[
<div "display: none;" =style div>
\r
TUPLE: db-persistence < filter-responder pool ;\r
\r
-: <db-persistence> ( responder params db -- responder' )\r
+: <db-persistence> ( responder db -- responder' )\r
<db-pool> db-persistence boa ;\r
\r
M: db-persistence call-responder*\r
<action>\r
[ [ ] "text/plain" <content> exit-with ] >>display ;\r
\r
-[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors\r
+[ "auth-test.db" temp-file delete-file ] ignore-errors\r
\r
-"auth-test.db" temp-file sqlite-db [\r
+"auth-test.db" temp-file <sqlite-db> [\r
\r
<request> init-request\r
session ensure-table\r
Doug Coleman
Ryan Murphy
+Slava Pestov
USING: heaps.private help.markup help.syntax kernel math assocs
-math.order ;
+math.order quotations ;
IN: heaps
ARTICLE: "heaps" "Heaps"
"Removal:"
{ $subsection heap-pop* }
{ $subsection heap-pop }
-{ $subsection heap-delete } ;
+{ $subsection heap-delete }
+"Processing heaps:"
+{ $subsection slurp-heap } ;
ABOUT: "heaps"
{ $description "Remove the specified entry from the heap." }
{ $errors "Throws an error if the entry is from another heap or if it has already been deleted." }
{ $side-effects "heap" } ;
+
+HELP: slurp-heap
+{ $values
+ { "heap" "a heap" } { "quot" quotation } }
+{ $description "Removes values from a heap and processes them with the quotation until the heap is empty." } ;
! Copyright 2007, 2008 Ryan Murphy, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-
USING: arrays kernel math namespaces tools.test
heaps heaps.private math.parser random assocs sequences sorting
accessors math.order ;
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
] each
-: delete-random ( seq -- elt )
- dup length random dup pick nth >r swap delete-nth r> ;
-
: sort-entries ( entries -- entries' )
[ [ key>> ] compare ] sort ;
{ $subsection "math-constants" }
{ $subsection "math-functions" }
{ $subsection "number-strings" }
-{ $subsection "random-numbers" }
+{ $subsection "random" }
"Number implementations:"
{ $subsection "integers" }
{ $subsection "rationals" }
--- /dev/null
+IN: help.html.tests
+USING: html.streams classes.predicate help.topics help.markup
+io.streams.string accessors prettyprint kernel tools.test ;
+
+[ ] [ [ [ \ predicate-instance? def>> . ] with-html-writer ] with-string-writer drop ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
+io.files html.streams html.elements html.components help kernel
+assocs sequences make words accessors arrays help.topics vocabs
+tools.vocabs tools.vocabs.browser namespaces prettyprint io
+vocabs.loader serialize fry memoize unicode.case math.order
+sorting ;
IN: help.html
+: escape-char ( ch -- )
+ dup H{
+ { CHAR: " "__quote__" }
+ { CHAR: * "__star__" }
+ { CHAR: : "__colon__" }
+ { CHAR: < "__lt__" }
+ { CHAR: > "__gt__" }
+ { CHAR: ? "__question__" }
+ { CHAR: \\ "__backslash__" }
+ { CHAR: | "__pipe__" }
+ { CHAR: _ "__underscore__" }
+ { CHAR: / "__slash__" }
+ { CHAR: \\ "__backslash__" }
+ { CHAR: , "__comma__" }
+ } at [ % ] [ , ] ?if ;
+: escape-filename ( string -- filename )
+ [ [ escape-char ] each ] "" make ;
+
+GENERIC: topic>filename* ( topic -- name prefix )
+
+M: word topic>filename*
+ dup vocabulary>> [
+ [ name>> ] [ vocabulary>> ] bi 2array "word"
+ ] [ drop f f ] if ;
+
+M: link topic>filename* name>> dup [ "article" ] [ topic>filename* ] if ;
+M: word-link topic>filename* name>> topic>filename* ;
+M: vocab-spec topic>filename* vocab-name "vocab" ;
+M: vocab-tag topic>filename* name>> "tag" ;
+M: vocab-author topic>filename* name>> "author" ;
+M: f topic>filename* drop \ f topic>filename* ;
+
+: topic>filename ( topic -- filename )
+ topic>filename* dup [
+ [
+ % "-" %
+ dup array?
+ [ [ escape-filename ] map "," join ]
+ [ escape-filename ]
+ if % ".html" %
+ ] "" make
+ ] [ 2drop f ] if ;
+
+M: topic browser-link-href topic>filename ;
+
+: help-stylesheet ( -- )
+ "resource:basis/help/html/stylesheet.css" ascii file-contents write ;
+
+: help>html ( topic -- )
+ dup topic>filename utf8 [
+ dup article-title
+ [ <style> help-stylesheet </style> ]
+ [ [ help ] with-html-writer ] simple-page
+ ] with-file-writer ;
+
+: all-vocabs-really ( -- seq )
+ #! Hack.
+ all-vocabs values concat
+ vocabs [ find-vocab-root not ] filter [ vocab ] map append ;
+
+: all-topics ( -- topics )
+ [
+ articles get keys [ >link ] map %
+ all-words [ >link ] map %
+ all-authors [ <vocab-author> ] map %
+ all-tags [ <vocab-tag> ] map %
+ all-vocabs-really %
+ ] { } make ;
+
+: serialize-index ( index file -- )
+ [ [ [ topic>filename ] dip ] { } assoc-map-as object>bytes ] dip
+ binary set-file-contents ;
+
+: generate-indices ( -- )
+ articles get keys [ [ >link ] [ article-title ] bi ] { } map>assoc "articles.idx" serialize-index
+ all-words [ dup name>> ] { } map>assoc "words.idx" serialize-index
+ all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ;
+
+: generate-help-files ( -- )
+ all-topics [ help>html ] each ;
+
+: generate-help ( -- )
+ { "resource:core" "resource:basis" "resource:extra" } vocab-roots [
+ load-everything
+
+ "/tmp/docs/" make-directory
+
+ "/tmp/docs/" [
+ generate-indices
+ generate-help-files
+ ] with-directory
+ ] with-variable ;
+
+MEMO: load-index ( name -- index )
+ binary file-contents bytes>object ;
+
+TUPLE: result title href ;
+
+M: result link-title title>> ;
+
+M: result link-href href>> ;
+
+: offline-apropos ( string index -- results )
+ load-index swap >lower
+ '[ [ drop _ ] dip >lower subseq? ] assoc-filter
+ [ swap result boa ] { } assoc>map
+ [ [ title>> ] compare ] sort ;
+
+: article-apropos ( string -- results )
+ "articles.idx" offline-apropos ;
+
+: word-apropos ( string -- results )
+ "words.idx" offline-apropos ;
+
+: vocab-apropos ( string -- results )
+ "vocabs.idx" offline-apropos ;
--- /dev/null
+a:link { text-decoration: none; color: #00004c; }
+a:visited { text-decoration: none; color: #00004c; }
+a:active { text-decoration: none; color: #00004c; }
+a:hover { text-decoration: underline; color: #00004c; }
[ strong-style get print-element* ] ($span) ;
: $url ( children -- )
- [ url-style get print-element* ] ($span) ;
+ [
+ dup first href associate url-style get assoc-union
+ print-element*
+ ] ($span) ;
: $nl ( children -- )
nl nl drop ;
{ $class-description "Text area components display a multi-line editor for a string value. The " { $slot "rows" } " and " { $slot "cols" } " properties determine the size of the text area." } ;
HELP: link
-{ $description "Link components render a link to an object stored at a value, with the link title and URL determined by the " { $link link-title } " and " { $link link-href } " generic words." } ;
+{ $description "Link components render a link to an object stored at a value, with the link title and URL determined by the " { $link link-title } " and " { $link link-href } " generic words. The optional " { $slot "target" } " slot is a target frame to open the link in." } ;
HELP: link-title
{ $values { "obj" object } { "string" string } }
[ ] [ link-test "link" set-value ] unit-test
[ "<a href='http://www.apple.com/foo&bar'><Link Title></a>" ] [
- [ "link" link render ] with-string-writer
+ [ "link" link new render ] with-string-writer
] unit-test
[ ] [
[ t ] [
[ "object" inspector render ] with-string-writer
- [ "object" value [ describe ] with-html-stream ] with-string-writer
+ [ "object" value [ describe ] with-html-writer ] with-string-writer
=
] unit-test
choice new ;
: render-option ( text selected? -- )
- <option [ "true" =selected ] when option>
+ <option [ "selected" =selected ] when option>
present escape-string write
</option> ;
M: url link-title ;
M: url link-href ;
-SINGLETON: link
+TUPLE: link target ;
M: link render*
- 2drop
- <a dup link-href =href a>
+ nip
+ <a target>> [ =target ] when* dup link-href =href a>
link-title present escape-string write
</a> ;
SINGLETON: inspector
M: inspector render*
- 2drop [ describe ] with-html-stream ;
+ 2drop [ describe ] with-html-writer ;
! Diff component
SINGLETON: comparison
"hr"
"link"
"img"
+ "base"
] [ define-open-html-word ] each
! Define some attributes
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title" "multiple" "checked"
"summary" "cellspacing" "align" "scope" "abbr"
- "nofollow" "alt"
+ "nofollow" "alt" "target"
] [ define-attribute-word ] each
>>
"<?xml version=\"1.0\"?>" write-html
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;
-: simple-page ( title quot -- )
+: simple-page ( title head-quot body-quot -- )
#! Call the quotation, with all output going to the
#! body of an html page with the given title.
+ spin
xhtml-preamble
<html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
- <head> <title> swap write </title> </head>
+ <head>
+ <title> write </title>
+ call
+ </head>
<body> call </body>
</html> ; inline
{ $values { "stream" "an output stream" } { "html-stream" html-stream } }
{ $description "Creates a new formatted output stream which emits HTML markup on " { $snippet "stream" } "." } ;
-HELP: with-html-stream
+HELP: with-html-writer
{ $values { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-stream } " wrapping the current " { $link output-stream } "." }
{ $examples
{ $example
"USING: io io.styles html.streams ;"
- "[ \"Hello\" { { font-style bold } } format nl ] with-html-stream"
+ "[ \"Hello\" { { font-style bold } } format nl ] with-html-writer"
"<span style='font-style: normal; font-weight: bold; '>Hello</span><br/>"
}
} ;
"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "styles" } " by writing HTML markup to the wrapped stream."
{ $subsection html-stream }
{ $subsection <html-stream> }
-{ $subsection with-html-stream } ;
+{ $subsection with-html-writer } ;
ABOUT: "html.streams"
IN: html.streams.tests
: make-html-string
- [ with-html-stream ] with-string-writer ; inline
+ [ with-html-writer ] with-string-writer ; inline
[ [ ] make-html-string ] must-infer
[ H{ } [ ] with-nesting nl ] make-html-string
] unit-test
-[ ] [ [ { 1 2 3 } describe ] with-html-stream ] unit-test
+[ ] [ [ { 1 2 3 } describe ] with-html-writer ] unit-test
io.files continuations io.streams.string kernel math math.order
math.parser namespaces make quotations assocs sequences strings
words html.elements xml.entities sbufs continuations destructors
-accessors arrays ;
+accessors arrays urls.encoding ;
IN: html.streams
GENERIC: browser-link-href ( presented -- href )
: not-a-div ( stream -- stream )
f >>last-div ; inline
-: a-div ( stream -- straem )
+: a-div ( stream -- stream )
t >>last-div ; inline
: <html-stream> ( stream -- html-stream )
: object-link-tag ( style quot -- )
presented pick at [
browser-link-href [
- <a =href a> call </a>
+ <a url-encode =href a> call </a>
] [ call ] if*
] [ call ] if* ; inline
+: href-link-tag ( style quot -- )
+ href pick at [
+ <a url-encode =href a> call </a>
+ ] [ call ] if* ; inline
+
: hex-color, ( color -- )
[ red>> ] [ green>> ] [ blue>> ] tri
[ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ;
: format-html-span ( string style stream -- )
stream>> [
- [ [ drop write ] span-tag ] object-link-tag
+ [ [ [ drop write ] span-tag ] href-link-tag ] object-link-tag
] with-output-stream* ;
TUPLE: html-span-stream < html-sub-stream ;
M: html-stream dispose stream>> dispose ;
-: with-html-stream ( quot -- )
+: with-html-writer ( quot -- )
output-stream get <html-stream> swap with-output-stream* ; inline
{ $values { "name" "the tag name" } { "definition" "a quotation with stack effect " { $snippet "( tag -- )" } } }
{ $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ;
-HELP: CHLOE-SINGLETON:
-{ $syntax "CHLOE-SINGLETON: name" }
-{ $description "Defines a Chloe tag named " { $snippet "name" } " rendering an HTML component with singleton class word " { $snippet "name" } ". See " { $link "html.components" } "." } ;
-
-HELP: CHLOE-TUPLE:
-{ $syntax "CHLOE-TUPLE: name" }
-{ $description "Defines a Chloe tag named " { $snippet "name" } " rendering an HTML component with tuple class word " { $snippet "name" } ". See " { $link "html.components" } "." } ;
+HELP: COMPONENT:
+{ $syntax "COMPONENT: name" }
+{ $description "Defines a Chloe tag named " { $snippet "name" } " rendering the HTML component with class word " { $snippet "name" } ". See " { $link "html.components" } "." } ;
HELP: reset-cache
{ $description "Resets the compiled template cache. Chloe automatically recompiles templates when their file changes on disk, however other when redefining Chloe tags or words which they call, the cache may have to be reset manually for the changes to take effect." } ;
"s</a>"
}
} }
+ { { $snippet "t:base" } { "Outputs an HTML " { $snippet "<base>" } " tag. The attributes are interpreted in the same manner as the attributes of " { $snippet "t:a" } "." } }
{ { $snippet "t:form" } {
"Renders a form; extends the standard XHTML " { $snippet "form" } " tag by providing some integration with other web framework features, for example by adding hidden fields for authentication credentials and session management allowing those features to work with form submission transparently. The following attributes are supported:"
{ $list
"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "html.elements" } ":"
{ $code "M: image render* 2drop <img =src img/> ;" }
"Finally, we can define a Chloe component:"
-{ $code "CHLOE-SINGLETON: image" }
+{ $code "COMPONENT: image" }
"We can use it as follows, assuming the current form has a value named " { $snippet "image" } ":"
{ $code "<t:image t:name='image' />" } ;
ARTICLE: "html.templates.chloe.extend.components" "Extending Chloe with custom components"
"Custom HTML components implementing the " { $link render* } " word can be wired up with Chloe using the following syntax from " { $vocab-link "html.templates.chloe.components" } ":"
-{ $subsection POSTPONE: CHLOE-SINGLETON: }
-{ $subsection POSTPONE: CHLOE-TUPLE: }
+{ $subsection POSTPONE: COMPONENT: }
{ $subsection "html.templates.chloe.extend.components.example" } ;
ARTICLE: "html.templates.chloe" "Chloe templates"
CHLOE: if dup if>quot [ swap when ] append process-children ;
-CHLOE-SINGLETON: label
-CHLOE-SINGLETON: link
-CHLOE-SINGLETON: inspector
-CHLOE-SINGLETON: comparison
-CHLOE-SINGLETON: html
-CHLOE-SINGLETON: hidden
-
-CHLOE-TUPLE: farkup
-CHLOE-TUPLE: field
-CHLOE-TUPLE: textarea
-CHLOE-TUPLE: password
-CHLOE-TUPLE: choice
-CHLOE-TUPLE: checkbox
-CHLOE-TUPLE: code
+COMPONENT: label
+COMPONENT: link
+COMPONENT: inspector
+COMPONENT: comparison
+COMPONENT: html
+COMPONENT: hidden
+COMPONENT: farkup
+COMPONENT: field
+COMPONENT: textarea
+COMPONENT: password
+COMPONENT: choice
+COMPONENT: checkbox
+COMPONENT: code
SYMBOL: template-cache
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel parser fry quotations
-classes.tuple
+classes.tuple classes.singleton
html.components
html.templates.chloe.compiler
html.templates.chloe.syntax ;
IN: html.templates.chloe.components
+
+GENERIC: component-tag ( tag class -- )
-: singleton-component-tag ( tag class -- )
+M: singleton-class component-tag ( tag class -- )
[ "name" required-attr compile-attr ]
[ literalize [ render ] [code-with] ]
bi* ;
-: CHLOE-SINGLETON:
- scan-word
- [ name>> ] [ '[ _ singleton-component-tag ] ] bi
- define-chloe-tag ;
- parsing
-
: compile-component-attrs ( tag class -- )
[ attrs>> [ drop main>> "name" = not ] assoc-filter ] dip
[ all-slots swap '[ name>> _ at compile-attr ] each ]
[ [ boa ] [code-with] ]
bi ;
-: tuple-component-tag ( tag class -- )
+M: tuple-class component-tag ( tag class -- )
[ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi
[ render ] [code] ;
-: CHLOE-TUPLE:
+: COMPONENT:
scan-word
- [ name>> ] [ '[ _ tuple-component-tag ] ] bi
+ [ name>> ] [ '[ _ component-tag ] ] bi
define-chloe-tag ;
parsing
USING: http help.markup help.syntax io.files io.streams.string
io.encodings.8-bit io.encodings.binary kernel strings urls
-byte-arrays strings assocs sequences ;
+urls.encoding byte-arrays strings assocs sequences ;
IN: http.client
HELP: download-failed
{ $description "Submits a form at a URL." }
{ $errors "Throws an error if the HTTP request fails." } ;
+HELP: with-http-get
+{ $values { "url" "a " { $link url } " or " { $link string } } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } }
+{ $description "Downloads the contents of a URL. Chunks of data are passed to the quotation as they are read." }
+{ $errors "Throws an error if the HTTP request fails." } ;
+
HELP: http-request
{ $values { "request" request } { "response" response } { "data" sequence } }
{ $description "Sends an HTTP request to an HTTP server, and reads the response." }
{ $errors "Throws an error if the HTTP request fails." } ;
+HELP: with-http-request
+{ $values { "request" request } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } }
+{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." }
+{ $errors "Throws an error if the HTTP request fails." } ;
+
ARTICLE: "http.client.get" "GET requests with the HTTP client"
"Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:"
{ $subsection http-get }
{ $subsection download-to }
"Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:"
{ $subsection <get-request> }
-{ $subsection http-request } ;
+{ $subsection http-request }
+"The " { $link http-get } " and " { $link http-request } " words output sequences. This is undesirable if the response data may be large. Another pair of words take a quotation instead, and pass the quotation chunks of data incrementally:"
+{ $subsection with-http-get }
+{ $subsection with-http-request } ;
ARTICLE: "http.client.post" "POST requests with the HTTP client"
"As with GET requests, there is a high-level word which takes a " { $link url } " and a lower-level word which constructs an HTTP request object which can be passed to " { $link http-request } ":"
ARTICLE: "http.client" "HTTP client"
"The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "."
$nl
+"For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't load it, HTTPS will not load and images generated by " { $vocab-link "tools.deploy" } " will be smaller as a result."
+$nl
"There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:"
{ $subsection "http.client.get" }
{ $subsection "http.client.post" }
USING: http.client http.client.private http tools.test
namespaces urls ;
+
+\ download must-infer
+
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
USING: accessors assocs kernel math math.parser namespaces make
sequences io io.sockets io.streams.string io.files io.timeouts
strings splitting calendar continuations accessors vectors
-math.order hashtables byte-arrays prettyprint
+math.order hashtables byte-arrays prettyprint destructors
io.encodings
io.encodings.string
io.encodings.ascii
io.encodings.8-bit
io.encodings.binary
io.streams.duplex
-fry debugger summary ascii urls present
+fry debugger summary ascii urls urls.encoding present
http http.parsers ;
IN: http.client
drop
[ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
-DEFER: (http-request)
-
<PRIVATE
+DEFER: (with-http-request)
+
SYMBOL: redirects
: redirect-url ( request url -- request )
'[ _ >url derive-url ensure-port ] change-url ;
-: do-redirect ( response data -- response data )
- over code>> 300 399 between? [
- drop
- redirects inc
- redirects get max-redirects < [
- request get
- swap "location" header redirect-url
- "GET" >>method (http-request)
- ] [
- too-many-redirects
- ] if
- ] when ;
+: redirect? ( response -- ? )
+ code>> 300 399 between? ;
-PRIVATE>
+: do-redirect ( quot: ( chunk -- ) response -- response )
+ redirects inc
+ redirects get max-redirects < [
+ request get clone
+ swap "location" header redirect-url
+ "GET" >>method swap (with-http-request)
+ ] [ too-many-redirects ] if ; inline recursive
: read-chunk-size ( -- n )
read-crlf ";" split1 drop [ blank? ] trim-right
hex> [ "Bad chunk size" throw ] unless* ;
-: read-chunks ( -- )
+: read-chunked ( quot: ( chunk -- ) -- )
read-chunk-size dup zero?
- [ drop ] [ read % read-crlf B{ } assert= read-chunks ] if ;
-
-: read-response-body ( response -- response data )
- dup "transfer-encoding" header "chunked" = [
- binary decode-input
- [ read-chunks ] B{ } make
- over content-charset>> decode
- ] [
- dup content-charset>> decode-input
- input-stream get contents
- ] if ;
-
-: (http-request) ( request -- response data )
- dup request [
- dup url>> url-addr ascii [
- 1 minutes timeouts
- write-request
- read-response
- read-response-body
- ] with-client
- do-redirect
- ] with-variable ;
+ [ 2drop ] [
+ read [ swap call ] [ drop ] 2bi
+ read-crlf B{ } assert= read-chunked
+ ] if ; inline recursive
+
+: read-unchunked ( quot: ( chunk -- ) -- )
+ 8192 read-partial dup [
+ [ swap call ] [ drop read-unchunked ] 2bi
+ ] [ 2drop ] if ; inline recursive
+
+: read-response-body ( quot response -- )
+ binary decode-input
+ "transfer-encoding" header "chunked" =
+ [ read-chunked ] [ read-unchunked ] if ; inline
+
+: <request-socket> ( -- stream )
+ request get url>> url-addr ascii <client> drop
+ 1 minutes over set-timeout ;
+
+: (with-http-request) ( request quot: ( chunk -- ) -- response )
+ swap
+ request [
+ <request-socket> [
+ [
+ out>>
+ [ request get write-request ]
+ with-output-stream*
+ ] [
+ in>> [
+ read-response dup redirect? [ t ] [
+ [ nip response set ]
+ [ read-response-body ]
+ [ ]
+ 2tri f
+ ] if
+ ] with-input-stream*
+ ] bi
+ ] with-disposal
+ [ do-redirect ] [ nip ] if
+ ] with-variable ; inline recursive
+
+PRIVATE>
: success? ( code -- ? ) 200 = ;
-ERROR: download-failed response body ;
+ERROR: download-failed response ;
M: download-failed error.
- "HTTP download failed:" print nl
- [ response>> . nl ] [ body>> write ] bi ;
+ "HTTP request failed:" print nl
+ response>> . ;
+
+: check-response ( response -- response )
+ dup code>> success? [ download-failed ] unless ;
-: check-response ( response data -- response data )
- over code>> success? [ download-failed ] unless ;
+: with-http-request ( request quot -- response )
+ (with-http-request) check-response ; inline
: http-request ( request -- response data )
- (http-request) check-response ;
+ [ [ % ] with-http-request ] B{ } make
+ over content-charset>> decode ;
: <get-request> ( url -- request )
<request>
: http-get ( url -- response data )
<get-request> http-request ;
+: with-http-get ( url quot -- response )
+ [ <get-request> ] dip with-http-request ; inline
+
: download-name ( url -- name )
present file-name "?" split1 drop "/" ?tail drop ;
: download-to ( url file -- )
- #! Downloads the contents of a URL to a file.
- swap http-get
- [ content-charset>> ] [ '[ _ write ] ] bi*
- with-file-writer ;
+ binary [ [ write ] with-http-get drop ] with-file-writer ;
: download ( url -- )
dup download-name download-to ;
: add-quit-action
<action>
- [ stop-server "Goodbye" "text/html" <content> ] >>display
+ [ stop-this-server "Goodbye" "text/html" <content> ] >>display
"quit" add-responder ;
-: test-db "test.db" temp-file sqlite-db ;
+: test-db-file "test.db" temp-file ;
-[ test-db drop delete-file ] ignore-errors
+: test-db test-db-file <sqlite-db> ;
+
+[ test-db-file delete-file ] ignore-errors
test-db [
init-furnace-tables
USING: accessors kernel combinators math namespaces make
assocs sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
-math.parser calendar calendar.format present urls logging
+math.parser calendar calendar.format present urls
io io.encodings io.encodings.iana io.encodings.binary
io.encodings.8-bit
drop
] { } make ;
-\ parse-cookie DEBUG add-input-logging
-
: check-cookie-string ( string -- string' )
dup "=;'\"\r\n" intersect empty?
[ "Bad cookie name or value" throw ] unless ;
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit math math.order math.parser
kernel sequences sequences.deep peg peg.parsers assocs arrays
-hashtables strings unicode.case namespaces make ascii logging ;
+hashtables strings unicode.case namespaces make ascii ;
IN: http.parsers
: except ( quot -- parser )
'space' ,
] seq* just ;
-\ parse-request-line DEBUG add-input-logging
-
: 'text' ( -- parser )
[ ctl? ] except ;
! Copyright (C) 2007, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: namespaces kernel assocs io.files io.streams.duplex\r
-combinators arrays io.launcher io http.server.static http.server\r
-http accessors sequences strings math.parser fry urls ;\r
+combinators arrays io.launcher io.encodings.binary io\r
+http.server.static http.server http accessors sequences strings\r
+math.parser fry urls urls.encoding calendar ;\r
IN: http.server.cgi\r
\r
: cgi-variables ( script-path -- assoc )\r
: <cgi-process> ( name -- desc )\r
<process>\r
over 1array >>command\r
- swap cgi-variables >>environment ;\r
+ swap cgi-variables >>environment\r
+ 1 minutes >>timeout ;\r
\r
: serve-cgi ( name -- response )\r
<raw-response>\r
200 >>code\r
"CGI output follows" >>message\r
swap '[\r
- _ output-stream get swap <cgi-process> <process-stream> [\r
+ _ output-stream get swap <cgi-process>
binary <process-stream> [
\r post-request? [ request get post-data>> raw>> write flush ] when\r
input-stream get swap (stream-copy)\r
] with-stream\r
io.streams.limited
io.servers.connection
io.timeouts
-fry logging logging.insomniac calendar urls
+fry logging logging.insomniac calendar urls urls.encoding
http
http.parsers
http.server.responses
html.streams ;
IN: http.server
+\ parse-cookie DEBUG add-input-logging
+
: check-absolute ( url -- url )
dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
[ add-responder-nesting ] [ call-responder* ] 2bi ;
: http-error. ( error -- )
- "Internal server error" [
- [ print-error nl :c ] with-html-stream
+ "Internal server error" [ ] [
+ [ print-error nl :c ] with-html-writer
] simple-page ;
: <500> ( error -- response )
{ $notes "See " { $link "html.templates.fhtml" } "." }
{ $side-effects "responder" } ;
-ARTICLE: "http.server.static" "Serving static content"
-"The " { $vocab-link "http.server.static" } " vocabulary implements a responder for serving static files."
-{ $subsection <static> }
-"The static responder does not serve directory listings by default, as a security measure. Directory listings can be enabled by storing a true value in the " { $slot "allow-listings" } " slot."
-$nl
+ARTICLE: "http.server.static.extend" "Hooks for dynamic content"
"The static responder can be extended for dynamic content by associating quotations with MIME types in the hashtable stored in the " { $slot "special" } " slot. The quotations have stack effect " { $snippet "( path -- )" } "."
$nl
"A utility word uses the above feature to enable server-side " { $snippet ".fhtml" } " scripts, allowing a development style much like PHP:"
{ $subsection <file-responder> }
"The default just sends the file's contents with the request; " { $vocab-link "xmode.code2html.responder" } " provides an alternate hook which sends a syntax-highlighted version of the file." ;
+ARTICLE: "http.server.static" "Serving static content"
+"The " { $vocab-link "http.server.static" } " vocabulary implements a responder for serving static files."
+{ $subsection <static> }
+"The static responder does not serve directory listings by default, as a security measure. Directory listings can be enabled by storing a true value in the " { $slot "allow-listings" } " slot."
+$nl
+"If all you want to do is serve files from a directory, the following phrase does the trick:"
+{ $code
+ "USING: namespaces http.server http.server.static ;"
+ "/var/www/mysite.com/ <static> main-responder set"
+ "8080 httpd"
+}
+{ $subsection "http.server.static.extend" } ;
+
ABOUT: "http.server.static"
USING: calendar io io.files kernel math math.order\r
math.parser namespaces parser sequences strings\r
assocs hashtables debugger mime-types sorting logging\r
-calendar.format accessors\r
+calendar.format accessors splitting\r
io.encodings.binary fry xml.entities destructors urls\r
html.elements html.templates.fhtml\r
http\r
\r
TUPLE: file-responder root hook special allow-listings ;\r
\r
+: modified-since ( request -- date )\r
+ "if-modified-since" header ";" split1 drop\r
+ dup [ rfc822>timestamp ] when ;\r
+\r
: modified-since? ( filename -- ? )\r
- request get "if-modified-since" header dup [\r
- [ file-info modified>> ] [ rfc822>timestamp ] bi* after?\r
+ request get modified-since dup [\r
+ [ file-info modified>> ] dip after?\r
] [\r
2drop t\r
] if ;\r
dup <a =href a> escape-string write </a> ;\r
\r
: directory. ( path -- )\r
- dup file-name [\r
+ dup file-name [ ] [\r
[ <h1> file-name escape-string write </h1> ]\r
[\r
<ul>\r
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test interpolate ;
+IN: interpolate.tests
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io kernel macros make multiline namespaces parser
+peg.ebnf present sequences strings ;
+IN: interpolate
+
+MACRO: interpolate ( string -- )
+[EBNF
+var = "${" [^}]+ "}" => [[ second >string [ get present write ] curry ]]
+text = [^$]+ => [[ >string [ write ] curry ]]
+interpolate = (var|text)* => [[ [ ] join ]]
+EBNF] ;
+
+EBNF: interpolate-locals
+var = "${" [^}]+ "}" => [[ [ second >string search , [ present write ] % ] [ ] make ]]
+text = [^$]+ => [[ [ >string , [ write ] % ] [ ] make ]]
+interpolate = (var|text)* => [[ [ ] join ]]
+;EBNF
+
+: I[ "]I" parse-multiline-string
+ interpolate-locals parsed \ call parsed ; parsing
HELP: ascii
{ $class-description "ASCII encoding descriptor." } ;
-ARTICLE: "ascii" "ASCII encoding"
+ARTICLE: "io.encodings.ascii" "ASCII encoding"
"By default, if there's a non-ASCII character in an input stream, it will be replaced with a replacement character (U+FFFD), and if a non-ASCII character is used in output, an exception is thrown."
{ $subsection ascii } ;
-ABOUT: "ascii"
+ABOUT: "io.encodings.ascii"
{ $subsection start-server }
{ $subsection start-server* }
{ $subsection wait-for-server }
+"Stopping the server:"
+{ $subsection stop-server }
"From within the dynamic scope of a client handler, several words can be used to interact with the threaded server:"
{ $subsection remote-address }
-{ $subsection stop-server }
+{ $subsection stop-this-server }
{ $subsection secure-port }
{ $subsection insecure-port }
"Additionally, the " { $link local-address } " variable is set, as in " { $link with-client } "." ;
HELP: start-server
{ $values { "threaded-server" threaded-server } }
-{ $description "Starts a threaded server, returning when a client handler calls " { $link stop-server } "." } ;
+{ $description "Starts a threaded server." }
+{ $notes "Use " { $link stop-server } " or " { $link stop-this-server } " to stop the server." } ;
HELP: wait-for-server
{ $values { "threaded-server" threaded-server } }
HELP: start-server*
{ $values { "threaded-server" threaded-server } }
-{ $description "Starts a threaded server, returning as soon as it is accepting connections." } ;
+{ $description "Starts a threaded server, returning as soon as it is ready to begin accepting connections." } ;
HELP: stop-server
+{ $values { "threaded-server" threaded-server } }
+{ $description "Stops a threaded server, preventing it from accepting any more connections and returning to the caller of " { $link start-server } ". All client connections which have already been opened continue to be serviced." } ;
+
+HELP: stop-this-server
{ $description "Stops the current threaded server, preventing it from accepting any more connections and returning to the caller of " { $link start-server } ". All client connections which have already been opened continue to be serviced." } ;
HELP: secure-port
<threaded-server>
5 >>max-connections
1237 >>insecure
- [ "Hello world." write stop-server ] >>handler
+ [ "Hello world." write stop-this-server ] >>handler
"server" set
] unit-test
threaded-server get encoding>> <server>
[ started-accept-loop ] [ [ accept-loop ] with-disposal ] bi ;
-\ start-accept-loop ERROR add-error-logging
+\ start-accept-loop NOTICE add-error-logging
: init-server ( threaded-server -- threaded-server )
dup semaphore>> [
[ wait-for-server ]
bi ;
-: stop-server ( -- )
- threaded-server get [ f ] change-sockets drop dispose-each ;
+: stop-server ( threaded-server -- )
+ [ f ] change-sockets drop dispose-each ;
+
+: stop-this-server ( -- )
+ threaded-server get stop-server ;
GENERIC: port ( addrspec -- n )
} ;
HELP: with-client
-{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "quot" quotation } }
+{ $values { "remote" "an address specifier" } { "encoding" "an encoding descriptor" } { "quot" quotation } }
{ $description "Opens a network connection and calls the quotation in a new dynamic scope with " { $link input-stream } " and " { $link output-stream } " rebound to the network streams. The local address the socket is bound to is stored in the " { $link local-address } " variable." }
{ $errors "Throws an error if the connection cannot be established." } ;
! Addressing
GENERIC: protocol-family ( addrspec -- af )
-GENERIC: sockaddr-type ( addrspec -- type )
+GENERIC: sockaddr-size ( addrspec -- n )
GENERIC: make-sockaddr ( addrspec -- sockaddr )
+GENERIC: empty-sockaddr ( addrspec -- sockaddr )
+
GENERIC: address-size ( addrspec -- n )
GENERIC: inet-ntop ( data addrspec -- str )
GENERIC: inet-pton ( str addrspec -- data )
: make-sockaddr/size ( addrspec -- sockaddr size )
- [ make-sockaddr ] [ sockaddr-type heap-size ] bi ;
+ [ make-sockaddr ] [ sockaddr-size ] bi ;
: empty-sockaddr/size ( addrspec -- sockaddr size )
- sockaddr-type [ <c-object> ] [ heap-size ] bi ;
+ [ empty-sockaddr ] [ sockaddr-size ] bi ;
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
M: inet4 protocol-family drop PF_INET ;
-M: inet4 sockaddr-type drop "sockaddr-in" c-type ;
+M: inet4 sockaddr-size drop "sockaddr-in" heap-size ;
+
+M: inet4 empty-sockaddr drop "sockaddr-in" <c-object> ;
M: inet4 make-sockaddr ( inet -- sockaddr )
"sockaddr-in" <c-object>
M: inet6 protocol-family drop PF_INET6 ;
-M: inet6 sockaddr-type drop "sockaddr-in6" c-type ;
+M: inet6 sockaddr-size drop "sockaddr-in6" heap-size ;
+
+M: inet6 empty-sockaddr drop "sockaddr-in6" <c-object> ;
M: inet6 make-sockaddr ( inet -- sockaddr )
"sockaddr-in6" <c-object>
SYMBOL: presented-path
SYMBOL: presented-printer
+SYMBOL: href
+
! Paragraph styles
SYMBOL: page-color
SYMBOL: border-color
! Unix domain sockets
M: local protocol-family drop PF_UNIX ;
-M: local sockaddr-type drop "sockaddr-un" c-type ;
+M: local sockaddr-size drop "sockaddr-un" heap-size ;
+
+M: local empty-sockaddr drop "sockaddr-un" <c-object> ;
M: local make-sockaddr
path>> (normalize-path)
USING: alien alien.c-types arrays assocs combinators
continuations destructors io io.backend io.ports io.timeouts
-io.windows io.windows.files libc kernel math namespaces
-sequences threads windows windows.errors windows.kernel32
-strings splitting io.files io.buffers qualified ascii system
-accessors locals ;
+io.windows io.windows.files io.files io.buffers io.streams.c
+libc kernel math namespaces sequences threads windows
+windows.errors windows.kernel32 strings splitting qualified
+ascii system accessors locals ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
[ finish-read ]
tri
] with-destructors ;
+
+M: winnt (init-stdio) init-c-stdio ;
dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
: init-accept-buffer ( addr AcceptEx -- )
- swap sockaddr-type heap-size 16 +
+ swap sockaddr-size 16 +
[ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
drop ; inline
WSARecvFrom-args new
swap >>port
dup port>> handle>> handle>> >>s
- dup port>> addr>> sockaddr-type heap-size
+ dup port>> addr>> sockaddr-size
[ malloc &free >>lpFrom ]
[ malloc-int &free >>lpFromLen ] bi
make-receive-buffer >>lpBuffers
HELP: ::
{ $syntax ":: word ( bindings... -- outputs... ) body... ;" }
-{ $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." }
+{ $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." }
{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." }
{ $examples "See " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " and " { $link POSTPONE: [wlet } "." } ;
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
ARTICLE: "locals-mutable" "Mutable locals"
-"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's with the " { $snippet "!" } " suffix."
+"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's name with the " { $snippet "!" } " suffix."
$nl
"Here is a example word which outputs a pair of quotations which increment and decrement an internal counter, and then return the new value. The quotations are closed over the counter and each invocation of the word yields new quotations with their unique internal counter:"
{ $code
USING: math.intervals kernel sequences words math math.order
arrays prettyprint tools.test random vocabs combinators
-accessors ;
+accessors math.constants ;
IN: math.intervals.tests
[ empty-interval ] [ 2 2 (a,b) ] unit-test
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: accessors kernel sequences arrays math math.order
HELP: present
{ $values { "object" object } { "string" string } }
{ $contract "Outputs a human-readable string from an object." }
-{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $link "html.components" } " or " { $link "urls" } " vocabularies." } ;
+{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $vocab-link "html.components" } " or " { $link "urls" } " vocabularies." } ;
ABOUT: "present"
: pprint-; ( -- ) \ ; pprint-word ;
-: (see) ( spec -- )
- <colon dup synopsis*
- <block dup definition pprint-elements block>
- dup definer nip [ pprint-word ] when* declarations.
- block> ;
-
M: object see
- [ (see) ] with-use nl ;
+ [
+ 12 nesting-limit set
+ 100 length-limit set
+ <colon dup synopsis*
+ <block dup definition pprint-elements block>
+ dup definer nip [ pprint-word ] when* declarations.
+ block>
+ ] with-use nl ;
GENERIC: see-class* ( word -- )
dup class? over symbol? not and [
nl
] when
- dup class? over symbol? and not [
- [ dup (see) ] with-use nl
- ] when
- drop ;
+ dup [ class? ] [ symbol? ] bi and
+ [ drop ] [ call-next-method ] if ;
: see-all ( seq -- )
natural-sort [ nl ] [ see ] interleave ;
IN: random.mersenne-twister.tests
: check-random ( max -- ? )
- dup >r random 0 r> between? ;
+ [ random 0 ] keep between? ;
[ t ] [ 100 [ drop 674 check-random ] all? ] unit-test
-: make-100-randoms
- [ 100 [ 100 random , ] times ] { } make ;
+: randoms ( -- seq )
+ 100 [ 100 random ] replicate ;
: test-rng ( seed quot -- )
>r <mersenne-twister> r> with-random ;
-[ f ] [ 1234 [ make-100-randoms make-100-randoms = ] test-rng ] unit-test
+[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
[ 1333075495 ] [
0 [ 1000 [ drop random-generator get random-32* drop ] each random-generator get random-32* ] test-rng
-USING: help.markup help.syntax math ;
+USING: help.markup help.syntax math kernel sequences ;
IN: random
-ARTICLE: "random-numbers" "Generating random integers"
-"The " { $vocab-link "random" } " vocabulary implements the ``Mersenne Twister'' pseudo-random number generator algorithm."
-{ $subsection random } ;
-
-ABOUT: "random-numbers"
-
HELP: seed-random
{ $values { "tuple" "a random number generator" } { "seed" "an integer between 0 and 2^32-1" } }
{ $description "Seed the random number generator." }
{ $description "Generates a byte-array of random bytes." } ;
HELP: random
-{ $values { "seq" "a sequence" } { "elt" "a random element" } }
-{ $description "Outputs a random element of the sequence. If the sequence is empty, always outputs " { $link f } "." }
-{ $notes "Since integers are sequences, passing an integer " { $snippet "n" } " yields a random integer in the interval " { $snippet "[0,n)" } "." } ;
+{ $values { "obj" object } { "elt" "a random element" } }
+{ $description "Outputs a random element of the input object. If the object is an integer, an input of zero always returns a zero, while any other integer integers yield a random integer in the interval between itself and zero, inclusive of zero. On a sequence, an empty sequence always outputs " { $link f } "." }
+{ $examples
+ { $unchecked-example "USING: random prettyprint ;"
+ "10 random ."
+ "3" }
+ { $example "USING: random prettyprint ;"
+ "0 random ."
+ "0" }
+ { $unchecked-example "USING: random prettyprint ;"
+ "-10 random ."
+ "-8" }
+ { $unchecked-example "USING: random prettyprint ;"
+ "{ \"a\" \"b\" \"c\" } random ."
+ "\"a\"" }
+} ;
HELP: random-bytes
{ $values { "n" "an integer" } { "byte-array" "a random integer" } }
{ $values { "quot" "a quotation" } }
{ $description "Calls the quotation with the secure random generator in a dynamic variable. All random numbers will be generated using this random generator." } ;
-{ with-random with-secure-random } related-words
+HELP: with-system-random
+{ $values { "quot" "a quotation" } }
+{ $description "Calls the quotation with the system's random generator in a dynamic variable. All random numbers will be generated using this random generator." } ;
+
+{ with-random with-secure-random with-system-random } related-words
+
+HELP: delete-random
+{ $values
+ { "seq" sequence }
+ { "elt" object } }
+{ $description "Deletes a random number from a sequence using " { $link delete-nth } " and returns the deleted object." } ;
+
+ARTICLE: "random-protocol" "Random protocol"
+"A random number generator must implement one of these two words:"
+{ $subsection random-32* }
+{ $subsection random-bytes* }
+"Optional, to seed a random number generator:"
+{ $subsection seed-random } ;
+
+ARTICLE: "random" "Generating random integers"
+"The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers. The ``Mersenne Twister'' pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "."
+"Generate a random object:"
+{ $subsection random }
+"Combinators to change the random number generator:"
+{ $subsection with-random }
+{ $subsection with-system-random }
+{ $subsection with-secure-random }
+"Implementation:"
+{ $subsection "random-protocol" }
+"Deleting a random element from a sequence:"
+{ $subsection delete-random } ;
+
+ABOUT: "random"
[ t ] [ 10000 [ 0 [ drop 400 random + ] reduce ] keep / 2 * 400 10 ~ ] unit-test
[ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test
+
+[ 0 ] [ 0 random ] unit-test
random-generator get random-bytes*
] keep head ;
-: random ( seq -- elt )
+GENERIC: random ( obj -- elt )
+
+: random-bits ( n -- r ) 2^ random ;
+
+<PRIVATE
+
+: random-integer ( n -- n' )
+ dup log2 7 + 8 /i 1+
+ [ random-bytes byte-array>bignum ]
+ [ 3 shift 2^ ] bi / * >integer ;
+
+PRIVATE>
+
+M: sequence random ( seq -- elt )
[ f ] [
- [
- length dup log2 7 + 8 /i 1+
- [ random-bytes byte-array>bignum ]
- [ 3 shift 2^ ] bi / * >integer
- ] keep nth
+ [ length random-integer ] keep nth
] if-empty ;
-: delete-random ( seq -- elt )
- [ length random ] keep [ nth ] 2keep delete-nth ;
+ERROR: negative-random n ;
+M: integer random ( integer -- integer' )
+ {
+ { [ dup 0 = ] [ ] }
+ { [ dup 0 < ] [ neg random-integer neg ] }
+ [ random-integer ]
+ } cond ;
-: random-bits ( n -- r ) 2^ random ;
+: delete-random ( seq -- elt )
+ [ length random-integer ] keep [ nth ] 2keep delete-nth ;
: with-random ( tuple quot -- )
random-generator swap with-variable ; inline
[ "item" tags-named [ rss2.0-entry ] map set-entries ]
tri ;
+: atom-entry-link ( tag -- url/f )
+ "link" tags-named [ "rel" swap at "alternate" = ] find nip
+ dup [ "href" swap at >url ] when ;
+
: atom1.0-entry ( tag -- entry )
entry new
swap {
[ "title" tag-named children>string >>title ]
- [ "link" tag-named "href" swap at >url >>url ]
+ [ atom-entry-link >>url ]
[
{ "content" "summary" } any-tag-named
dup children>> [ string? not ] contains?
IN: tools.deploy.backend
: copy-vm ( executable bundle-name extension -- vm )
- [ prepend-path ] dip append vm over copy-file ;
+ [ prepend-path ] dip append vm over copy-file ;
: copy-fonts ( name dir -- )
- append-path "resource:fonts/" swap copy-tree-into ;
+ deploy-ui? get [
+ append-path "resource:fonts/" swap copy-tree-into
+ ] [ 2drop ] if ;
: image-name ( vocab bundle-name -- str )
- prepend-path ".image" append ;
+ prepend-path ".image" append ;
: copy-lines ( -- )
readln [ print flush copy-lines ] when* ;
SINGLETON: quit-responder\r
\r
M: quit-responder call-responder*\r
- 2drop stop-server "Goodbye" "text/html" <content> ;\r
+ 2drop stop-this-server "Goodbye" "text/html" <content> ;\r
\r
: add-quot-responder ( responder -- responder )\r
quit-responder "quit" add-responder ;\r
system tools.deploy.backend tools.deploy.config assocs
hashtables prettyprint io.unix.backend cocoa io.encodings.utf8
io.backend cocoa.application cocoa.classes cocoa.plists
-qualified ;
+qualified combinators ;
IN: tools.deploy.macosx
: bundle-dir ( -- dir )
"Contents/Info.plist" append-path
write-plist ;
+: copy-dll ( bundle-name -- )
+ "Frameworks/libfactor.dylib" copy-bundle-dir ;
+
+: copy-freetype ( bundle-name -- )
+ deploy-ui? get [ "Frameworks" copy-bundle-dir ] [ drop ] if ;
+
+: copy-nib ( bundle-name -- )
+ deploy-ui? get [
+ "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
+ ] [ drop ] if ;
+
: create-app-dir ( vocab bundle-name -- vm )
[
- nip
- [ "Frameworks" copy-bundle-dir ]
- [ "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir ]
- [ "Contents/Resources/" copy-fonts ] tri
+ nip {
+ [ copy-dll ]
+ [ copy-freetype ]
+ [ copy-nib ]
+ [ "Contents/Resources/" copy-fonts ]
+ [ "Contents/Resources" append-path make-directories ]
+ } cleave
]
[ create-app-plist ]
[ "Contents/MacOS/" append-path "" copy-vm ] 2tri ;
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors qualified io.streams.c init fry namespaces make
-assocs kernel parser lexer strings.parser tools.deploy.config
-vocabs sequences words words.private memory kernel.private
-continuations io prettyprint vocabs.loader debugger system
-strings sets vectors quotations byte-arrays sorting ;
+USING: accessors qualified io.backend io.streams.c init fry
+namespaces make assocs kernel parser lexer strings.parser
+tools.deploy.config vocabs sequences words words.private memory
+kernel.private continuations io prettyprint vocabs.loader
+debugger system strings sets vectors quotations byte-arrays
+sorting compiler.units definitions ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
QUALIFIED: compiler.errors.private
-QUALIFIED: compiler.units
QUALIFIED: continuations
QUALIFIED: definitions
QUALIFIED: init
-QUALIFIED: io.backend
-QUALIFIED: io.thread
QUALIFIED: layouts
QUALIFIED: listener
QUALIFIED: prettyprint.config
] change-props drop
] each
] [
- "Remaining word properties:" print
- [ props>> keys ] gather .
+ "Remaining word properties:\n" show
+ [ props>> keys ] gather unparse show
] [
H{ } clone '[
[ [ _ [ ] cache ] map ] change-props drop
strip-word-names? [ dup strip-word-names ] when
2drop ;
-: strip-recompile-hook ( -- )
- [ [ f ] { } map>assoc ]
- compiler.units:recompile-hook
- set-global ;
-
: strip-vocab-globals ( except names -- words )
[ child-vocabs [ words ] map concat ] map concat swap diff ;
continuations:restarts
listener:error-hook
init:init-hooks
- io.thread:io-thread
source-files:source-files
input-stream
output-stream
error-stream
} %
+ "io-thread" "io.thread" lookup ,
+
"mallocs" "libc.private" lookup ,
deploy-threads? [
"initial-thread" "threads" lookup ,
] unless
- strip-io? [ io.backend:io-backend , ] when
+ strip-io? [ io-backend , ] when
{ } {
"alarms"
command-line:main-vocab-hook
compiled-crossref
compiled-generic-crossref
- compiler.units:recompile-hook
- compiler.units:update-tuples-hook
- compiler.units:definition-observers
+ recompile-hook
+ update-tuples-hook
+ definition-observers
definitions:crossref
interactive-vocabs
layouts:num-tags
21 setenv
] [ drop ] if ;
+: strip-c-io ( -- )
+ deploy-io get 2 = [
+ [
+ c-io-backend forget
+ "io.streams.c" forget-vocab
+ ] with-compilation-unit
+ ] unless ;
+
: compress ( pred string -- )
"Compressing " prepend show
instances
init-hooks get values concat %
,
strip-io? [ \ flush , ] unless
- ] [ ] make "Boot quotation: " write dup . flush
+ ] [ ] make "Boot quotation: " show dup unparse show
set-boot-quot ;
+: init-stripper ( -- )
+ t "quiet" set-global
+ f output-stream set-global ;
+
: strip ( -- )
+ init-stripper
strip-libc
strip-cocoa
strip-debugger
- strip-recompile-hook
strip-init-hooks
+ strip-c-io
+ f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
deploy-vocab get vocab-main set-boot-quot*
stripped-word-props >r
stripped-globals strip-globals
r> strip-words
compress-byte-arrays
compress-quotations
- compress-strings ;
+ compress-strings
+ H{ } clone classes:next-method-quot-cache set-global ;
: (deploy) ( final-image vocab config -- )
#! Does the actual work of a deployment in the slave
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
namespaces kernel kernel.private words compiler.units sequences
-ui ui.cocoa init ;
+init vocabs ;
IN: tools.deploy.shaker.cocoa
: pool ( obj -- obj' ) \ pool get [ ] cache ;
H{ } clone \ pool [
global [
- stop-after-last-window? set
+ "stop-after-last-window?" "ui" lookup set
- [ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global
+ "ui.cocoa" vocab [
+ [ "MiniFactor.nib" load-nib ]
+ "cocoa-init-hook" "ui.cocoa" lookup set-global
+ ] when
! Only keeps those methods that we actually call
sent-messages get super-sent-messages get assoc-union
-USING: kernel threads threads.private ;
+USING: compiler.units words vocabs kernel threads.private ;
IN: debugger
: print-error ( error -- ) die drop ;
: error. ( error -- ) die drop ;
-M: thread error-in-thread ( error thread -- ) die 2drop ;
+"threads" vocab [
+ [
+ "error-in-thread" "threads" lookup
+ [ die 2drop ]
+ define
+ ] with-compilation-unit
+] when
prettyprint combinators windows.shell32 windows.user32 ;
IN: tools.deploy.windows
-: copy-dlls ( bundle-name -- )
- {
- "resource:freetype6.dll"
- "resource:zlib1.dll"
- "resource:factor.dll"
- } swap copy-files-into ;
+: copy-dll ( bundle-name -- )
+ "resource:factor.dll" swap copy-file-into ;
+
+: copy-freetype ( bundle-name -- )
+ deploy-ui? get [
+ {
+ "resource:freetype6.dll"
+ "resource:zlib1.dll"
+ } swap copy-files-into
+ ] when ;
: create-exe-dir ( vocab bundle-name -- vm )
- dup copy-dlls
- dup "" copy-fonts
+ deploy-ui? get [
+ dup copy-dll
+ dup copy-freetype
+ dup "" copy-fonts
+ ] when
".exe" copy-vm ;
M: winnt deploy*
HELP: developer-name
{ $description "Set this symbol to hold your name so that the scaffold tools can generate the correct file header for copyright. Setting this variable in your .factor-boot-rc file is recommended." }
-{ $unchecked-example "USING: namespaces tools.scaffold ;\n\"Stacky Guy\" developer-name set-global" } ;
+{ $code "USING: namespaces tools.scaffold ;\n\"Stacky Guy\" developer-name set-global" } ;
HELP: help.
{ $values
{ $description "Prints out scaffold help markup for a given word." } ;
HELP: scaffold-help
-{ $values
- { "vocab-root" "a vocabulary root string" } { "string" string } }
+{ $values { "string" string } }
{ $description "Takes an existing vocabulary and creates a help file with scaffolded help for each word. This word only works if no help file yet exists." } ;
HELP: scaffold-undocumented
: help. ( word -- )
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
-: scaffold-help ( vocab-root string -- )
+: scaffold-help ( string -- )
[
- check-vocab
+ [ find-vocab-root ] [ check-vocab ] bi
prepare-scaffold
[ "-docs.factor" scaffold-path ] dip
swap [ set-scaffold-help-file ] [ 2drop ] if
{ $subsection grid }
"Creating grids from a fixed set of gadgets:"
{ $subsection <grid> }
-"Managing chidren:"
+"Managing children:"
{ $subsection grid-add }
{ $subsection grid-remove }
{ $subsection grid-child } ;
! Copyright (C) 2006, 2007 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences io.styles ui.gadgets ui.render
-colors accessors ;
+colors colors.gray qualified accessors ;
+QUALIFIED: colors
IN: ui.gadgets.theme
: solid-interior ( gadget color -- gadget )
<solid> >>boundary ; inline
: faint-boundary ( gadget -- gadget )
- gray solid-boundary ; inline
+ colors:gray solid-boundary ; inline
: selection-color ( -- color ) light-purple ;
{ T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] }
{ T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] }
{ T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
- { T{ button-down f { C+ } 1 } [ T{ button-down f f 3 } swap resend-button-down ] }
- { T{ button-down f { A+ } 1 } [ T{ button-down f f 2 } swap resend-button-down ] }
- { T{ button-up f { C+ } 1 } [ T{ button-up f f 3 } swap resend-button-up ] }
- { T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }
+ { T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] }
+ { T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
+ { T{ button-up f { C+ } 1 } [ drop T{ button-up f f 3 } button-gesture ] }
+ { T{ button-up f { A+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
} set-gestures
: close-global ( world global -- )
: send-action ( world gesture -- )
swap world-focus send-gesture drop ;
-: resend-button-down ( gesture world -- )
- hand-loc get-global swap send-button-down ;
-
-: resend-button-up ( gesture world -- )
- hand-loc get-global swap send-button-up ;
-
GENERIC: gesture>string ( gesture -- string/f )
: modifiers>string ( modifiers -- string )
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit unicode.categories kernel math
combinators splitting sequences math.parser io.files io assocs
arrays namespaces make math.ranges unicode.normalize values
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: unicode.data sequences sequences.next namespaces make
unicode.normalize math unicode.categories combinators
assocs strings splitting kernel accessors ;
: final-sigma ( string -- string )
HEX: 3A3 over member? [ sigma-map ] when ;
-! : map-case ( string string-quot char-quot -- case )
-! [
-! rot [
-! -rot [
-! rot dup special-casing at
-! [ -rot drop call % ]
-! [ -rot nip call , ] ?if
-! ] 2keep
-! ] each 2drop
-! ] "" make ; inline
-
: map-case ( string string-quot char-quot -- case )
[
[
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: unicode.syntax ;
IN: unicode.categories
: test-two ( str1 str2 -- )\r
[ +lt+ ] -rot [ string<=> ] 2curry unit-test ;\r
\r
-: failures\r
- parse-test dup 2 <clumps>\r
- [ string<=> +lt+ = not ] assoc-filter dup assoc-size ;\r
-\r
-: test-equality\r
+: test-equality ( str1 str2 -- )\r
{ primary= secondary= tertiary= quaternary= }\r
[ execute ] with with each ;\r
\r
+! Copyright (C) 2008 Daniel Ehrenberg.\r
+! See http://factorcode.org/license.txt for BSD license.\r
USING: combinators.short-circuit sequences io.files\r
io.encodings.ascii kernel values splitting accessors math.parser\r
ascii io assocs strings math namespaces make sorting combinators\r
] { } map-as concat ;\r
\r
: append-weights ( weights quot -- )\r
- swap [ ignorable?>> not ] filter\r
- swap map [ zero? not ] filter % 0 , ;\r
+ [ [ ignorable?>> not ] filter ] dip\r
+ map [ zero? not ] filter % 0 , ; inline\r
\r
: variable-weight ( weight -- )\r
dup ignorable?>> [ primary>> ] [ drop HEX: FFFF ] if , ;\r
<PRIVATE\r
: insensitive= ( str1 str2 levels-removed -- ? )\r
[\r
- swap collation-key swap\r
+ [ collation-key ] dip\r
[ [ 0 = not ] trim-right but-last ] times\r
] curry bi@ = ;\r
PRIVATE>\r
PRIVATE>\r
\r
: sort-strings ( strings -- sorted )\r
- [ w/collation-key ] map\r
- natural-sort values ;\r
+ [ w/collation-key ] map natural-sort values ;\r
\r
: string<=> ( str1 str2 -- <=> )\r
[ w/collation-key ] compare ;\r
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit assocs math kernel sequences
io.files hashtables quotations splitting grouping arrays
math.parser hash2 math.order byte-arrays words namespaces words
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: sequences namespaces make unicode.data kernel math arrays
locals sorting.insertion accessors ;
IN: unicode.normalize
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: accessors values kernel sequences assocs io.files
io.encodings ascii math.ranges io splitting math.parser
namespaces make byte-arrays locals math sets io.encodings.ascii
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
USING: unicode.data kernel math sequences parser lexer
bit-arrays namespaces make sequences.private arrays quotations
assocs classes.predicate math.order eval ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: unix
USING: alien.syntax ;
+IN: unix
! Linux.
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-
-USING: alien alien.c-types alien.syntax kernel libc structs sequences
- continuations byte-arrays strings
- math namespaces system combinators vocabs.loader qualified
- accessors stack-checker macros locals generalizations
- unix.types debugger io prettyprint ;
-
+USING: alien alien.c-types alien.syntax kernel libc structs
+sequences continuations byte-arrays strings math namespaces
+system combinators vocabs.loader qualified accessors
+stack-checker macros locals generalizations unix.types
+debugger io prettyprint ;
IN: unix
TYPEDEF: uint in_addr_t
FUNCTION: gid_t getgid ;
FUNCTION: int getgrgid_r ( gid_t gid, group* grp, char* buffer, size_t bufsize, group** result ) ;
FUNCTION: int getgrnam_r ( char* name, group* grp, char* buffer, size_t bufsize, group** result ) ;
+FUNCTION: passwd* getpwent ( ) ;
FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ;
FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ;
+FUNCTION: int getgrouplist ( char* name, int basegid, int* groups, int* ngroups ) ;
+
+FUNCTION: group* getgrent ;
FUNCTION: int gethostname ( char* name, int len ) ;
FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ;
FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ;
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: urls.encoding
+USING: strings help.markup help.syntax assocs multiline ;
+
+HELP: url-decode
+{ $values { "str" string } { "decoded" string } }
+{ $description "Decodes a URL-encoded string." } ;
+
+HELP: url-encode
+{ $values { "str" string } { "encoded" string } }
+{ $description "URL-encodes a string." } ;
+
+HELP: url-quotable?
+{ $values { "ch" "a character" } { "?" "a boolean" } }
+{ $description "Tests if a character be used without URL-encoding in a URL." } ;
+
+HELP: assoc>query
+{ $values { "assoc" assoc } { "str" string } }
+{ $description "Converts an assoc of query parameters into a query string, performing URL encoding." }
+{ $notes "This word is used by the implementation of " { $link "urls" } ". It is also used by the HTTP client to encode POST requests." }
+{ $examples
+ { $example
+ "USING: io urls.encoding ;"
+ "{ { \"from\" \"Lead\" } { \"to\" \"Gold, please\" } }"
+ "assoc>query print"
+ "from=Lead&to=Gold%2c%20please"
+ }
+} ;
+
+HELP: query>assoc
+{ $values { "query" string } { "assoc" assoc } }
+{ $description "Parses a URL query string and URL-decodes each component." }
+{ $notes "This word is used by the implementation of " { $link "urls" } ". It is also used by the HTTP server to parse POST requests." }
+{ $examples
+ { $unchecked-example
+ "USING: prettyprint urls.encoding ;"
+ "\"gender=female&agefrom=22&ageto=28&location=Omaha+NE\""
+ "query>assoc ."
+ <" H{
+ { "gender" "female" }
+ { "agefrom" "22" }
+ { "ageto" "28" }
+ { "location" "Omaha NE" }
+}">
+ }
+} ;
+
+ARTICLE: "url-encoding" "URL encoding and decoding"
+"URL encoding and decoding strings:"
+{ $subsection url-encode }
+{ $subsection url-decode }
+{ $subsection url-quotable? }
+"Encoding and decoding queries:"
+{ $subsection assoc>query }
+{ $subsection query>assoc }
+"See " { $url "http://en.wikipedia.org/wiki/Percent-encoding" } " for a description of URL encoding." ;
+
+ABOUT: "url-encoding"
--- /dev/null
+IN: urls.encoding.tests
+USING: urls.encoding tools.test arrays kernel assocs present accessors ;
+
+[ "~hello world" ] [ "%7ehello world" url-decode ] unit-test
+[ f ] [ "%XX%XX%XX" url-decode ] unit-test
+[ f ] [ "%XX%XX%X" url-decode ] unit-test
+
+[ "hello world" ] [ "hello%20world" url-decode ] unit-test
+[ " ! " ] [ "%20%21%20" url-decode ] unit-test
+[ "hello world" ] [ "hello world%" url-decode ] unit-test
+[ "hello world" ] [ "hello world%x" url-decode ] unit-test
+[ "hello%20world" ] [ "hello world" url-encode ] unit-test
+
+[ "hello world" ] [ "hello+world" query-decode ] unit-test
+
+[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
+
+[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
+
+[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
+
+[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
+
+[ H{ { "a" { "b" "c" } } } ] [ "a=b;a=c" query>assoc ] unit-test
+
+[ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test
+
+[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ascii combinators combinators.short-circuit
+sequences splitting fry namespaces make assocs arrays strings
+io.encodings.string io.encodings.utf8 math math.parser accessors
+hashtables present ;
+IN: urls.encoding
+
+: url-quotable? ( ch -- ? )
+ {
+ [ letter? ]
+ [ LETTER? ]
+ [ digit? ]
+ [ "/_-.:" member? ]
+ } 1|| ; foldable
+
+<PRIVATE
+
+: push-utf8 ( ch -- )
+ 1string utf8 encode
+ [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+
+PRIVATE>
+
+: url-encode ( str -- encoded )
+ [
+ [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
+ ] "" make ;
+
+<PRIVATE
+
+: url-decode-hex ( index str -- )
+ 2dup length 2 - >= [
+ 2drop
+ ] [
+ [ 1+ dup 2 + ] dip subseq hex> [ , ] when*
+ ] if ;
+
+: url-decode-% ( index str -- index str )
+ 2dup url-decode-hex ;
+
+: url-decode-iter ( index str -- )
+ 2dup length >= [
+ 2drop
+ ] [
+ 2dup nth dup CHAR: % = [
+ drop url-decode-% [ 3 + ] dip
+ ] [
+ , [ 1+ ] dip
+ ] if url-decode-iter
+ ] if ;
+
+PRIVATE>
+
+: url-decode ( str -- decoded )
+ [ 0 swap url-decode-iter ] "" make utf8 decode ;
+
+: query-decode ( str -- decoded )
+ [ dup CHAR: + = [ drop "%20" ] [ 1string ] if ] { } map-as
+ concat url-decode ;
+
+<PRIVATE
+
+: add-query-param ( value key assoc -- )
+ [
+ at [
+ {
+ { [ dup string? ] [ swap 2array ] }
+ { [ dup array? ] [ swap suffix ] }
+ { [ dup not ] [ drop ] }
+ } cond
+ ] when*
+ ] 2keep set-at ;
+
+PRIVATE>
+
+: query>assoc ( query -- assoc )
+ dup [
+ "&;" split H{ } clone [
+ [
+ [ "=" split1 [ dup [ query-decode ] when ] bi@ swap ] dip
+ add-query-param
+ ] curry each
+ ] keep
+ ] when ;
+
+: assoc>query ( assoc -- str )
+ [
+ dup array? [ [ present ] map ] [ present 1array ] if
+ ] assoc-map
+ [
+ [
+ [ url-encode ] dip
+ [ url-encode "=" swap 3append , ] with each
+ ] assoc-each
+ ] { } make "&" join ;
--- /dev/null
+URL and form encoding/decoding
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: urls urls.private io.sockets io.sockets.secure ;
+IN: urls.secure
+
+M: abstract-inet >secure-addr <secure> ;
}
} ;
-HELP: assoc>query
-{ $values { "assoc" assoc } { "str" string } }
-{ $description "Converts an assoc of query parameters into a query string, performing URL encoding." }
-{ $notes "This word is used to implement the " { $link present } " method on URLs; it is also used by the HTTP client to encode POST requests." }
-{ $examples
- { $example
- "USING: io urls ;"
- "{ { \"from\" \"Lead\" } { \"to\" \"Gold, please\" } }"
- "assoc>query print"
- "from=Lead&to=Gold%2c+please"
- }
-} ;
-
-HELP: query>assoc
-{ $values { "query" string } { "assoc" assoc } }
-{ $description "Parses a URL query string and URL-decodes each component." }
-{ $notes "This word is used to implement " { $link >url } ". It is also used by the HTTP server to parse POST requests." }
-{ $examples
- { $unchecked-example
- "USING: prettyprint urls ;"
- "\"gender=female&agefrom=22&ageto=28&location=Omaha+NE\""
- "query>assoc ."
- <" H{
- { "gender" "female" }
- { "agefrom" "22" }
- { "ageto" "28" }
- { "location" "Omaha NE" }
-}">
- }
-} ;
-
HELP: derive-url
{ $values { "base" url } { "url" url } { "url'" url } }
{ $description "Builds a URL by filling in missing components of " { $snippet "url" } " from " { $snippet "base" } "." }
}
} ;
+HELP: relative-url?
+{ $values
+ { "url" url }
+ { "?" "a boolean" } }
+{ $description "Tests whether a URL is relative." } ;
+
HELP: secure-protocol?
{ $values { "protocol" string } { "?" "a boolean" } }
{ $description "Tests if protocol connections must be made with secure sockets (SSL/TLS)." }
{ $values { "path1" string } { "path2" string } { "path" string } }
{ $description "Like " { $link append-path } ", but intended for use with URL paths and not filesystem paths." } ;
-HELP: url-decode
-{ $values { "str" string } { "decoded" string } }
-{ $description "Decodes a URL-encoded string." } ;
-
-HELP: url-encode
-{ $values { "str" string } { "encoded" string } }
-{ $description "URL-encodes a string." } ;
-
-HELP: url-quotable?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Tests if a character be used without URL-encoding in a URL." } ;
-
-ARTICLE: "url-encoding" "URL encoding and decoding"
-"URL encoding and decoding strings:"
-{ $subsection url-encode }
-{ $subsection url-decode }
-{ $subsection url-quotable? }
-"The URL implemention encodes and decodes components of " { $link url } " instances automatically, but sometimes it is required for non-URL strings. See " { $url "http://en.wikipedia.org/wiki/Percent-encoding" } " for a description of URL encoding." ;
-
ARTICLE: "url-utilities" "URL implementation utilities"
-{ $subsection assoc>query }
-{ $subsection query>assoc }
{ $subsection parse-host }
{ $subsection secure-protocol? }
{ $subsection url-append-path } ;
{ $subsection set-query-param }
"Creating " { $link "network-addressing" } " from URLs:"
{ $subsection url-addr }
-"Additional topics:"
-{ $subsection "url-utilities" }
-{ $subsection "url-encoding" } ;
+"The URL implemention encodes and decodes components of " { $link url } " instances automatically, but sometimes this functionality is needed for non-URL strings."
+{ $subsection "url-encoding" }
+"Utility words used by the URL implementation:"
+{ $subsection "url-utilities" } ;
ABOUT: "urls"
USING: urls urls.private tools.test
arrays kernel assocs present accessors ;
-[ "hello+world" ] [ "hello world" url-encode ] unit-test
-[ "hello world" ] [ "hello%20world" url-decode ] unit-test
-[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
-[ f ] [ "%XX%XX%XX" url-decode ] unit-test
-[ f ] [ "%XX%XX%X" url-decode ] unit-test
-
-[ "hello world" ] [ "hello+world" url-decode ] unit-test
-[ "hello world" ] [ "hello%20world" url-decode ] unit-test
-[ " ! " ] [ "%20%21%20" url-decode ] unit-test
-[ "hello world" ] [ "hello world%" url-decode ] unit-test
-[ "hello world" ] [ "hello world%x" url-decode ] unit-test
-[ "hello+world" ] [ "hello world" url-encode ] unit-test
-[ "+%21+" ] [ " ! " url-encode ] unit-test
-
-[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
-
-[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
-
-[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
-
-[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
-
-[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
-
: urls
{
{
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ascii combinators combinators.short-circuit
sequences splitting fry namespaces make assocs arrays strings
-io.sockets io.sockets.secure io.encodings.string
+io.sockets io.encodings.string
io.encodings.utf8 math math.parser accessors parser
strings.parser lexer prettyprint.backend hashtables present
-peg.ebnf ;
+peg.ebnf urls.encoding ;
IN: urls
-: url-quotable? ( ch -- ? )
- {
- [ letter? ]
- [ LETTER? ]
- [ digit? ]
- [ "/_-.:" member? ]
- } 1|| ; foldable
-
-<PRIVATE
-
-: push-utf8 ( ch -- )
- dup CHAR: \s = [ drop "+" % ] [
- 1string utf8 encode
- [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each
- ] if ;
-
-PRIVATE>
-
-: url-encode ( str -- encoded )
- [
- [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
- ] "" make ;
-
-<PRIVATE
-
-: url-decode-hex ( index str -- )
- 2dup length 2 - >= [
- 2drop
- ] [
- [ 1+ dup 2 + ] dip subseq hex> [ , ] when*
- ] if ;
-
-: url-decode-% ( index str -- index str )
- 2dup url-decode-hex [ 3 + ] dip ;
-
-: url-decode-+-or-other ( index str ch -- index str )
- dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
-
-: url-decode-iter ( index str -- )
- 2dup length >= [
- 2drop
- ] [
- 2dup nth dup CHAR: % = [
- drop url-decode-%
- ] [
- url-decode-+-or-other
- ] if url-decode-iter
- ] if ;
-
-PRIVATE>
-
-: url-decode ( str -- decoded )
- [ 0 swap url-decode-iter ] "" make utf8 decode ;
-
-<PRIVATE
-
-: add-query-param ( value key assoc -- )
- [
- at [
- {
- { [ dup string? ] [ swap 2array ] }
- { [ dup array? ] [ swap suffix ] }
- { [ dup not ] [ drop ] }
- } cond
- ] when*
- ] 2keep set-at ;
-
-PRIVATE>
-
-: query>assoc ( query -- assoc )
- dup [
- "&" split H{ } clone [
- [
- [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
- add-query-param
- ] curry each
- ] keep
- ] when ;
-
-: assoc>query ( assoc -- str )
- [
- dup array? [ [ present ] map ] [ present 1array ] if
- ] assoc-map
- [
- [
- [ url-encode ] dip
- [ url-encode "=" swap 3append , ] with each
- ] assoc-each
- ] { } make "&" join ;
-
TUPLE: url protocol username password host port path query anchor ;
: <url> ( -- url ) url new ;
: derive-url ( base url -- url' )
[ clone ] dip over {
- [ [ protocol>> ] either? >>protocol ]
- [ [ username>> ] either? >>username ]
- [ [ password>> ] either? >>password ]
- [ [ host>> ] either? >>host ]
- [ [ port>> ] either? >>port ]
- [ [ path>> ] bi@ swap url-append-path >>path ]
- [ [ query>> ] either? >>query ]
- [ [ anchor>> ] either? >>anchor ]
+ [ [ protocol>> ] either? >>protocol ]
+ [ [ username>> ] either? >>username ]
+ [ [ password>> ] either? >>password ]
+ [ [ host>> ] either? >>host ]
+ [ [ port>> ] either? >>port ]
+ [ [ path>> ] bi@ swap url-append-path >>path ]
+ [ [ query>> ] either? >>query ]
+ [ [ anchor>> ] either? >>anchor ]
} 2cleave ;
: relative-url ( url -- url' )
f >>host
f >>port ;
+: relative-url? ( url -- ? ) protocol>> not ;
+
! Half-baked stuff follows
: secure-protocol? ( protocol -- ? )
"https" = ;
+<PRIVATE
+
+GENERIC: >secure-addr ( addrspec -- addrspec' )
+
+PRIVATE>
+
: url-addr ( url -- addr )
[
[ host>> ]
[ protocol>> protocol-port ]
tri or <inet>
] [ protocol>> ] bi
- secure-protocol? [ <secure> ] when ;
+ secure-protocol? [ >secure-addr ] when ;
: ensure-port ( url -- url )
dup protocol>> '[ _ protocol-port or ] change-port ;
$nl
"Classes themselves form a class:"
{ $subsection class? }
-"You can ask an object for its class or superclass:"
+"You can ask an object for its class:"
{ $subsection class }
-{ $subsection superclass }
-{ $subsection superclasses }
"Testing if an object is an instance of a class:"
{ $subsection instance? }
+"You can ask a class for its superclass:"
+{ $subsection superclass }
+{ $subsection superclasses }
"Class predicates can be used to test instances directly:"
{ $subsection "class-predicates" }
"There is a universal class which all objects are an instance of, and an empty class with no instances:"
SYMBOL: classes-intersect-cache
SYMBOL: class-and-cache
SYMBOL: class-or-cache
+SYMBOL: next-method-quot-cache
: init-caches ( -- )
H{ } clone class<=-cache set
H{ } clone class-not-cache set
H{ } clone classes-intersect-cache set
H{ } clone class-and-cache set
- H{ } clone class-or-cache set ;
+ H{ } clone class-or-cache set
+ H{ } clone next-method-quot-cache set ;
: reset-caches ( -- )
class<=-cache get clear-assoc
class-not-cache get clear-assoc
classes-intersect-cache get clear-assoc
class-and-cache get clear-assoc
- class-or-cache get clear-assoc ;
+ class-or-cache get clear-assoc
+ next-method-quot-cache get clear-assoc ;
SYMBOL: update-map
M: boii jeah ;
"> eval
] unit-test
+
+! call-next-method cache test
+GENERIC: c-n-m-cache ( a -- b )
+
+! Force it to be unoptimized
+M: fixnum c-n-m-cache { } [ ] like call call-next-method ;
+M: integer c-n-m-cache 1 + ;
+M: number c-n-m-cache ;
+
+[ 3 ] [ 2 c-n-m-cache ] unit-test
+
+[ ] [ [ { integer c-n-m-cache } forget ] with-compilation-unit ] unit-test
+
+[ 2 ] [ 2 c-n-m-cache ] unit-test
GENERIC: next-method-quot* ( class generic combination -- quot )
: next-method-quot ( class generic -- quot )
- dup "combination" word-prop next-method-quot* ;
+ next-method-quot-cache get [
+ dup "combination" word-prop next-method-quot*
+ ] 2cache ;
: (call-next-method) ( class generic -- )
next-method-quot call ;
2bi ;
: create-method ( class generic -- method )
- 2dup method dup [
- 2nip
- ] [
- drop [ <method> dup ] 2keep reveal-method
+ 2dup method dup [ 2nip ] [
+ drop
+ [ <method> dup ] 2keep
+ reveal-method
+ reset-caches
] if ;
PREDICATE: default-method < word "default" word-prop ;
] keep eq?
[
[ [ delete-at ] with-methods ]
- [ [ delete-at ] with-implementors ]
- 2bi
+ [ [ delete-at ] with-implementors ] 2bi
+ reset-caches
] [ 2drop ] if
] if
]
SYMBOL: io-backend
+SINGLETON: c-io-backend
+
+c-io-backend io-backend set-global
+
HOOK: init-io io-backend ( -- )
HOOK: (init-stdio) io-backend ( -- stdin stdout stderr )
M: c-reader dispose*
handle>> fclose ;
-M: object init-io ;
+M: c-io-backend init-io ;
: stdin-handle 11 getenv ;
: stdout-handle 12 getenv ;
: stderr-handle 61 getenv ;
-M: object (init-stdio)
+: init-c-stdio ( -- stdin stdout stderr )
stdin-handle <c-reader>
stdout-handle <c-writer>
stderr-handle <c-writer> ;
-M: object io-multiplex 60 60 * 1000 * or (sleep) ;
+M: c-io-backend (init-stdio) init-c-stdio ;
-M: object (file-reader)
+M: c-io-backend io-multiplex 60 60 * 1000 * or (sleep) ;
+
+M: c-io-backend (file-reader)
"rb" fopen <c-reader> ;
-M: object (file-writer)
+M: c-io-backend (file-writer)
"wb" fopen <c-writer> ;
-M: object (file-appender)
+M: c-io-backend (file-appender)
"ab" fopen <c-writer> ;
: show ( msg -- )
[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test
[ "-0.0" ] [ -0.0 number>string ] unit-test
+
+[ "-3/4" ] [ -3/4 number>string ] unit-test
+[ "-1-1/4" ] [ -5/4 number>string ] unit-test
<PRIVATE
-: (>base) ( n -- str ) radix get >base ;
+: (>base) ( n -- str ) radix get positive>base ;
PRIVATE>
M: ratio >base
[
dup 0 < negative? set
- 1 /mod
+ abs 1 /mod
[ dup zero? [ drop "" ] [ (>base) sign append ] if ]
[
[ numerator (>base) ]
M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
-: empty? ( seq -- ? ) length zero? ; inline
+: empty? ( seq -- ? ) length 0 = ; inline
: if-empty ( seq quot1 quot2 -- )
[ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
prepose curry ; inline
: (interleave) ( n elt between quot -- )
- roll zero? [ nip ] [ swapd 2slip ] if call ; inline
+ roll 0 = [ nip ] [ swapd 2slip ] if call ; inline
PRIVATE>
[ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ;
: sequence= ( seq1 seq2 -- ? )
- 2dup [ length ] bi@ number=
+ 2dup [ length ] bi@ =
[ mismatch not ] [ 2drop f ] if ; inline
: sequence-hashcode-step ( oldhash newpart -- newhash )
M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: move ( to from seq -- )
- 2over number=
+ 2over =
[ 3drop ] [ [ nth swap ] [ set-nth ] bi ] if ; inline
<PRIVATE
<PRIVATE
: move-backward ( shift from to seq -- )
- 2over number= [
+ 2over = [
2drop 2drop
] [
[ >r 2over + pick r> move >r 1+ r> ] keep
] if ;
: move-forward ( shift from to seq -- )
- 2over number= [
+ 2over = [
2drop 2drop
] [
[ >r pick >r dup dup r> + swap r> move 1- ] keep
PRIVATE>
: open-slice ( shift from seq -- )
- pick zero? [
+ pick 0 = [
3drop
] [
pick over length + over >r >r
: padding ( seq n elt quot -- newseq )
[
- [ over length [-] dup zero? [ drop ] ] dip
+ [ over length [-] dup 0 = [ drop ] ] dip
[ <repetition> ] curry
] dip compose if ; inline
} ;
HELP: initial:
-{ $syntax "TUPLE: ... { \"slot\" initial: value } ... ;" }
+{ $syntax "TUPLE: ... { slot initial: value } ... ;" }
{ $values { "slot" "a slot name" } { "value" "any literal" } }
{ $description "Specifies an initial value for a tuple slot." } ;
HELP: read-only
-{ $syntax "TUPLE: ... { \"slot\" read-only } ... ;" }
+{ $syntax "TUPLE: ... { slot read-only } ... ;" }
{ $values { "slot" "a slot name" } }
{ $description "Defines a tuple slot to be read-only. If a tuple has read-only slots, instances of the tuple should only be created by calling " { $link boa } ", instead of " { $link new } ". Using " { $link boa } " is the only way to set the value of a read-only slot." } ;
UNION: x86 x86.32 x86.64 ;
-: cpu ( -- class ) \ cpu get ;
+: cpu ( -- class ) \ cpu get-global ; foldable
SINGLETON: winnt
SINGLETON: wince
UNION: unix bsd solaris linux ;
-: os ( -- class ) \ os get ;
+: os ( -- class ) \ os get-global ; foldable
<PRIVATE
M: array (quot-uses) seq-uses ;
+M: hashtable (quot-uses) >r >alist r> seq-uses ;
+
M: callable (quot-uses) seq-uses ;
M: wrapper (quot-uses) >r wrapped>> r> (quot-uses) ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string ;
+IN: assoc-heaps
+
+HELP: <assoc-heap>
+{ $description "Constructs a new " { $link assoc-heap } " from two existing data structures." } ;
+
+HELP: <unique-max-heap>
+{ $values
+
+ { "unique-heap" assoc-heap } }
+{ $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a max-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
+
+HELP: <unique-min-heap>
+{ $values
+ { "unique-heap" assoc-heap } }
+{ $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a min-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
+
+{ <unique-max-heap> <unique-min-heap> } related-words
+
+HELP: assoc-heap
+{ $description "A data structure containing an assoc and a heap to get certain properties with better time constraints at the expense of more space and complexity. For instance, a hashtable and a heap can be combined into one assoc-heap to get a sorted data structure with O(1) lookup. Operations on assoc-heap may update both the assoc and the heap or leave them out of sync if it's advantageous." } ;
+
+ARTICLE: "assoc-heaps" "Associative heaps"
+"The " { $vocab-link "assoc-heaps" } " vocabulary combines exists to synthesize data structures with better time properties than either of the two component data structures alone." $nl
+"Associative heap constructor:"
+{ $subsection <assoc-heap> }
+"Unique heaps:"
+{ $subsection <unique-min-heap> }
+{ $subsection <unique-max-heap> } ;
+
+ABOUT: "assoc-heaps"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test assoc-heaps ;
+IN: assoc-heaps.tests
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs hashtables heaps kernel ;
+IN: assoc-heaps
+
+TUPLE: assoc-heap assoc heap ;
+
+C: <assoc-heap> assoc-heap
+
+: <unique-min-heap> ( -- unique-heap )
+ H{ } clone <min-heap> <assoc-heap> ;
+
+: <unique-max-heap> ( -- unique-heap )
+ H{ } clone <max-heap> <assoc-heap> ;
+
+M: assoc-heap heap-push* ( value key assoc-heap -- entry )
+ pick over assoc>> key? [
+ 3drop f
+ ] [
+ [ assoc>> swapd set-at ] [ heap>> heap-push* ] 3bi
+ ] if ;
+
+M: assoc-heap heap-pop ( assoc-heap -- value key )
+ heap>> heap-pop ;
+
+M: assoc-heap heap-peek ( assoc-heap -- value key )
+ heap>> heap-peek ;
+
+M: assoc-heap heap-empty? ( assoc-heap -- value key )
+ heap>> heap-empty? ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
USING: math math.order kernel arrays byte-arrays sequences
-colors.hsv benchmark.mandel.params ;
+colors.hsv benchmark.mandel.params accessors colors ;
IN: benchmark.mandel.colors
: scale 255 * >fixnum ; inline
-: scale-rgb ( r g b -- n ) [ scale ] tri@ 3byte-array ;
+: scale-rgb ( rgba -- n )
+ [ red>> scale ] [ green>> scale ] [ blue>> scale ] tri 3byte-array ;
: sat 0.85 ; inline
: val 0.85 ; inline
: <color-map> ( nb-cols -- map )
dup [
360 * swap 1+ / sat val
- 3array hsv>rgb first3 scale-rgb
+ 1 <hsva> >rgba scale-rgb
] with map ;
: color-map ( -- map )
ARTICLE: "bubble-chamber" "Bubble Chamber"
- { $subsection "bubble-chamber-introduction" }
- { $subsection "bubble-chamber-particles" }
- { $subsection "bubble-chamber-author" }
- { $subsection "bubble-chamber-running" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber-introduction" "Introduction"
-
-"The Bubble Chamber is a generative painting system of imaginary "
+"The " { $vocab-link "bubble-chamber" }
+" is a generative painting system of imaginary "
"colliding particles. A single super-massive collision produces a "
"discrete universe of four particle types. Particles draw their "
-"positions over time as pixel exposures. " ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber-particles" "Particles"
-
+"positions over time as pixel exposures.\n"
+"\n"
"Four types of particles exist. The behavior and graphic appearance of "
-"each particle type is unique."
-
+"each particle type is unique.\n"
{ $subsection muon }
{ $subsection quark }
{ $subsection hadron }
- { $subsection axion } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber-author" "Author"
-
- "Bubble Chamber was created by Jared Tarbell. "
- "It was originally implemented in Processing. "
- "It was ported to Factor by Eduardo Cavazos. "
- "The original work is on display here: "
- { $url
- "http://www.complexification.net/gallery/machines/bubblechamber/" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber-running" "How to use"
+ { $subsection axion }
+"\n"
+"After you run the vocabulary, a window will appear. Click the "
+"mouse in a random area to fire 11 particles of each type. "
+"Another way to fire particles is to press the "
+"spacebar. This fires all the particles.\n"
+"\n"
+"Bubble Chamber was created by Jared Tarbell. "
+"It was originally implemented in Processing. "
+"It was ported to Factor by Eduardo Cavazos. "
+"The original work is on display here: "
+{ $url
+"http://www.complexification.net/gallery/machines/bubblechamber/" } ;
+
+ABOUT: "bubble-chamber"
- "After you run the vocabulary, a window will appear. Click the "
- "mouse in a random area to fire 11 particles of each type. "
- "Another way to fire particles is to press the "
- "spacebar. This fires all the particles." ;
\ No newline at end of file
swap value>> >>interior relayout-1 ;
: <color-model> ( model -- model )
- [ [ 256 /f ] map 1 suffix first4 rgba boa <solid> ] <filter> ;
+ [ first3 [ 256 /f ] tri@ 1 <rgba> <solid> ] <filter> ;
: <color-sliders> ( -- model gadget )
3 [ 0 0 0 255 <range> ] replicate
+! 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
+! 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 ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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 ;
-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 ;
+++ /dev/null
-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
-
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
+! 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
-Cryptographic algorithms implemented in Factor, such as MD5 and SHA1
+HMAC, XOR, Barrett, RSA, Timing
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
-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 ;
-USING: words kernel sequences combinators.lib locals\r
+USING: words kernel sequences locals\r
locals.private accessors parser namespaces continuations\r
summary definitions generalizations arrays ;\r
IN: descriptive\r
! 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
+! 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 { "seq" "a sequence" } }
+{ $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 { "seq" "a sequence" } { "str" "a string" } }
+{ $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"
-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
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 ;
USING: assocs html.parser kernel math sequences strings ascii
arrays generalizations shuffle unicode.case namespaces make
splitting http accessors io combinators http.client urls
-fry sequences.lib ;
+urls.encoding fry ;
IN: html.parser.analyzer
TUPLE: link attributes clickable ;
-: scrape-html ( url -- vector )
- http-get nip parse-html ;
+: scrape-html ( url -- headers vector )
+ http-get parse-html ;
: find-all ( seq quot -- alist )
[ <enum> >alist ] [ '[ second @ ] ] bi* filter ; inline
+! 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 ;
] 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 ;
! 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
: <LISP
"LISP>" parse-multiline-string define-lisp-builtins
- lisp-string>factor parsed \ call parsed ; parsing
\ No newline at end of file
+ lisp-string>factor parsed \ call parsed ; parsing
! 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
| string
s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
list-item = _ ( atom | s-expression ) _ => [[ second ]]
-;EBNF
\ No newline at end of file
+;EBNF
! Copyright (c) 2007 Samuel Tardieu
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions sequences ;
+USING: kernel math math.functions sequences fry ;
IN: math.algebra
: chinese-remainder ( aseq nseq -- x )
dup product
- [ [ over / [ swap gcd drop ] keep * * ] curry 2map sum ] keep rem ; foldable
+ [
+ '[ _ over / [ swap gcd drop ] keep * * ] 2map sum
+ ] keep rem ; foldable
+! Copyright (C) 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.constants math.functions math.intervals
-math.vectors namespaces sequences ;
+math.vectors namespaces sequences combinators.short-circuit ;
IN: math.analysis
<PRIVATE
: (gamma-lanczos6) ( x -- log[gamma[x+1]] )
#! log(gamma(x+1)
- dup 0.5 + dup gamma-g6 + dup >r log * r> -
- swap 6 gamma-z gamma-p6 v. log + ;
+ [ 0.5 + dup gamma-g6 + dup [ log * ] dip - ]
+ [ 6 gamma-z gamma-p6 v. log ] bi + ;
: gamma-lanczos6 ( x -- gamma[x] )
#! gamma(x) = gamma(x+1) / x
: gamma ( x -- y )
#! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt
#! gamma(n+1) = n! for n > 0
- dup 0.0 <= over 1.0 mod zero? and [
+ dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [
drop 1./0.
] [
dup abs gamma-lanczos6 swap dup 0 > [ drop ] [ gamma-neg ] if
] if ;
: nth-root ( n x -- y )
- over 0 = [ "0th root is undefined" throw ] when >r recip r> swap ^ ;
+ [ recip ] dip swap ^ ;
! Forth Scientific Library Algorithm #1
!
! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math math.order math.ranges mirrors
-namespaces make sequences sequences.lib sorting ;
+namespaces sequences sorting fry ;
IN: math.combinatorics
<PRIVATE
2dup - dupd > [ dupd - ] when ; inline
! See this article for explanation of the factoradic-based permutation methodology:
-! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
+! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
: factoradic ( n -- factoradic )
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ;
twiddle [ nPk ] keep factorial / ;
: permutation ( n seq -- seq )
- tuck permutation-indices swap nths ;
+ [ permutation-indices ] keep nths ;
: all-permutations ( seq -- seq )
- [
- [ length factorial ] keep [ permutation , ] curry each
- ] { } make ;
+ [ length factorial ] keep '[ _ permutation ] map ;
: inverse-permutation ( seq -- permutation )
<enum> >alist sort-values keys ;
-
: clamp ( a value b -- x )
min max ;
-
-
USING: kernel continuations combinators sequences math
math.order math.ranges accessors float-arrays ;
TUPLE: state x func h err i j errt fac hh ans a done ;
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
-: ntab ( -- val ) 8 ;
-: con ( -- val ) 1.6 ;
-: con2 ( -- val ) con con * ;
-: big ( -- val ) largest-float ;
-: safe ( -- val ) 2.0 ;
+: ntab ( -- val ) 8 ; inline
+: con ( -- val ) 1.6 ; inline
+: con2 ( -- val ) con con * ; inline
+: big ( -- val ) largest-float ; inline
+: safe ( -- val ) 2.0 ; inline
! Yes, this was ported from C code.
: a[i][i] ( state -- elt ) [ i>> ] [ i>> ] [ a>> ] tri nth nth ;
bi ;
: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
-: derivative-func ( func -- der ) [ derivative ] curry ;
\ No newline at end of file
+: derivative-func ( func -- der ) [ derivative ] curry ;
: ind ( n -- i )
2/ 1- ; inline
-: is-prime ( n erato -- bool )
- >r ind r> bits>> nth ; inline
+: is-prime ( n limit -- bool )
+ [ ind ] [ bits>> ] bi* nth ; inline
: indices ( n erato -- range )
limit>> ind over 3 * ind swap rot <range> ;
: odd ( seq -- seq ) 2 group 1 <column> ;
DEFER: fft
: two ( seq -- seq ) fft 2 v/n dup append ;
-: omega ( n -- n ) recip -2 pi i* * * exp ;
+: omega ( n -- n' ) recip -2 pi i* * * exp ;
: twiddle ( seq -- seq ) dup length dup omega swap n^v v* ;
: (fft) ( seq -- seq ) dup odd two twiddle swap even two v+ ;
: fft ( seq -- seq ) dup length 1 = [ (fft) ] unless ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: combinators combinators.lib io locals kernel math
math.functions math.ranges namespaces random sequences
hashtables sets ;
! Copyright © 2008 Reginald Keith Ford II
+! See http://factorcode.org/license.txt for BSD license.
! Newton's Method of approximating roots
-
USING: kernel math math.derivatives ;
IN: math.newtons-method
<PRIVATE
-: newton-step ( x function -- x2 ) dupd [ call ] [ derivative ] 2bi / - ;
-: newton-precision ( -- n ) 13 ;
+
+: newton-step ( x function -- x2 )
+ dupd [ call ] [ derivative ] 2bi / - ; inline
+
+: newton-precision ( -- n ) 13 ; inline
+
PRIVATE>
-: newtons-method ( guess function -- x ) newton-precision [ [ newton-step ] keep ] times drop ;
+
+: newtons-method ( guess function -- x )
+ newton-precision [ [ newton-step ] keep ] times drop ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences namespaces make math math.ranges
math.vectors vectors ;
IN: math.numerical-integration
SYMBOL: num-steps 180 num-steps set-global
+
: setup-simpson-range ( from to -- frange )
2dup swap - num-steps get / <range> ;
: generate-simpson-weights ( seq -- seq )
- [
- { 1 4 } % length 2 / 2 - { 2 4 } <repetition> concat % 1 ,
- ] { } make ;
+ { 1 4 }
+ swap length 2 / 2 - { 2 4 } <repetition> concat
+ { 1 } 3append ;
: integrate-simpson ( from to f -- x )
- >r setup-simpson-range r>
- dupd map dup generate-simpson-weights
+ [ setup-simpson-range dup ] dip
+ map dup generate-simpson-weights
v. swap [ third ] keep first - 6 / * ;
-
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences vectors math math.vectors
namespaces make shuffle splitting sequences.lib math.order ;
IN: math.polynomials
: polyval ( p x -- p[x] )
#! Evaluate a polynomial.
- >r dup length r> powers v. ;
+ [ dup length ] dip powers v. ;
<PRIVATE
: find-prime-miller-rabin ( n -- p )
- dup miller-rabin [ 2 + find-prime-miller-rabin ] unless ; foldable
+ dup miller-rabin [ 2 + find-prime-miller-rabin ] unless ; foldable
PRIVATE>
: next-prime ( n -- p )
- dup 999983 < [
- primes-under-million [ natural-search drop 1+ ] keep nth
- ] [
- next-odd find-prime-miller-rabin
- ] if ; foldable
+ dup 999983 < [
+ primes-under-million [ natural-search drop 1+ ] keep nth
+ ] [
+ next-odd find-prime-miller-rabin
+ ] if ; foldable
: prime? ( n -- ? )
- dup 1000000 < [
- dup primes-under-million natural-search nip =
- ] [
- miller-rabin
- ] if ; foldable
+ dup 1000000 < [
+ dup primes-under-million natural-search nip =
+ ] [
+ miller-rabin
+ ] if ; foldable
: lprimes ( -- list )
- 0 primes-under-million seq>list
- 1000003 [ 2 + find-prime-miller-rabin ] lfrom-by
- lappend ;
+ 0 primes-under-million seq>list
+ 1000003 [ 2 + find-prime-miller-rabin ] lfrom-by
+ lappend ;
: lprimes-from ( n -- list )
- dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ;
+ dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ;
: primes-upto ( n -- seq )
- {
- { [ dup 2 < ] [ drop { } ] }
- { [ dup 1000003 < ]
- [ primes-under-million [ natural-search drop 1+ 0 swap ] keep <slice> ] }
- [ primes-under-million 1000003 lprimes-from
- rot [ <= ] curry lwhile list>array append ]
- } cond ; foldable
+ {
+ { [ dup 2 < ] [ drop { } ] }
+ { [ dup 1000003 < ] [
+ primes-under-million [ natural-search drop 1+ 0 swap ] keep <slice>
+ ] }
+ [ primes-under-million 1000003 lprimes-from
+ rot [ <= ] curry lwhile list>array append ]
+ } cond ; foldable
: primes-between ( low high -- seq )
- primes-upto
- [ 1- next-prime ] dip
- [ natural-search drop ] keep [ length ] keep <slice> ; foldable
+ primes-upto
+ [ 1- next-prime ] dip
+ [ natural-search drop ] keep [ length ] keep <slice> ; foldable
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
: qconjugate ( u -- u' )
#! Quaternion conjugate.
- first2 neg >r conjugate r> 2array ;
+ first2 [ conjugate ] [ neg ] bi* 2array ;
: qrecip ( u -- 1/u )
#! Quaternion inverse.
! Copyright © 2008 Reginald Keith Ford II
+! See http://factorcode.org/license.txt for BSD license.
! Secant Method of approximating roots
-
USING: kernel math math.function-tools math.points math.vectors ;
IN: math.secant-method
<PRIVATE
-: secant-solution ( x1 x2 function -- solution ) [ eval ] curry bi@ linear-solution ;
-: secant-step ( x1 x2 func -- x2 x3 func ) 2dup [ secant-solution ] 2dip swapd ;
-: secant-precision ( -- n ) 15 ;
+
+: secant-solution ( x1 x2 function -- solution )
+ [ eval ] curry bi@ linear-solution ;
+
+: secant-step ( x1 x2 func -- x2 x3 func )
+ [ secant-solution ] 2keep swapd ;
+
+: secant-precision ( -- n ) 15 ; inline
+
PRIVATE>
-: secant-method ( left right function -- x ) secant-precision [ secant-step ] times drop + 2 / ;
+
+: secant-method ( left right function -- x )
+ secant-precision [ secant-step ] times drop + 2 / ;
+
! : close-enough? ( a b -- t/f ) - abs tiny-amount < ;
-! : secant-method2 ( left right function -- x ) 2over close-enough? [ drop average ] [ secant-step secant-method ] if ;
\ No newline at end of file
+
+! : secant-method2 ( left right function -- x )
+ ! 2over close-enough?
+ ! [ drop average ] [ secant-step secant-method ] if ;
+! Copyright (C) 2008 Doug Coleman, Michael Judge.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.analysis math.functions math.vectors sequences
- sequences.lib sorting ;
+sequences.lib sorting ;
IN: math.statistics
: mean ( seq -- n )
: median ( seq -- n )
#! middle number if odd, avg of two middle numbers if even
natural-sort dup length dup even? [
- 1- 2 / swap [ nth ] [ >r 1+ r> nth ] 2bi + 2 /
+ 1- 2 / swap [ nth ] [ [ 1+ ] dip nth ] 2bi + 2 /
] [
2 / swap nth
] if ;
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math math.functions math.parser namespaces
- sequences splitting grouping sequences.lib
- combinators.short-circuit ;
+sequences splitting grouping combinators.short-circuit ;
IN: math.text.english
<PRIVATE
] if ;
: (number>text) ( n -- str )
- dup negative-text swap abs 3digit-groups recombine append ;
+ [ negative-text ] [ abs 3digit-groups recombine ] bi append ;
PRIVATE>
: number>text ( n -- str )
- dup zero? [
- small-numbers
- ] [
- [ (number>text) ] with-scope
- ] if ;
+ dup zero? [ small-numbers ] [ [ (number>text) ] with-scope ] if ;
-
+! Copyright (C) 2008 Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
USING: math math.constants ;
-
IN: math.trig
: deg>rad pi * 180 / ; inline
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 )
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
{ $example
"USING: printf ;"
"1.23456789 \"%.3f\" printf"
- "1.234" }
+ "1.235" }
{ $example
"USING: printf ;"
"1234567890 \"%.5e\" printf"
- "1.23456e+09" }
+ "1.23457e+09" }
{ $example
"USING: printf ;"
"12 \"%'#4d\" printf"
[ t ] [ "+0010" 10 "%+05d" sprintf = ] unit-test
-[ t ] [ "123.456" 123.456 "%f" sprintf = ] unit-test
+[ t ] [ "123.456000" 123.456 "%f" sprintf = ] unit-test
+
+[ t ] [ "2.44" 2.436 "%.2f" sprintf = ] unit-test
[ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test
-[ t ] [ "1.2345" 1.23456789 "%.4f" sprintf = ] unit-test
+[ t ] [ "1.2346" 1.23456789 "%.4f" sprintf = ] unit-test
[ t ] [ " 1.23" 1.23456789 "%6.2f" sprintf = ] unit-test
-[ t ] [ "1.234e+08" 123400000 "%e" sprintf = ] unit-test
+[ t ] [ "1.234000e+08" 123400000 "%e" sprintf = ] unit-test
-[ t ] [ "-1.234e+08" -123400000 "%e" sprintf = ] unit-test
+[ t ] [ "-1.234000e+08" -123400000 "%e" sprintf = ] unit-test
[ t ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test
[ t ] [ "3.625e+08" 362525200 "%.3e" sprintf = ] unit-test
-[ t ] [ "2.5e-03" 0.0025 "%e" sprintf = ] unit-test
+[ t ] [ "2.500000e-03" 0.0025 "%e" sprintf = ] unit-test
-[ t ] [ "2.5E-03" 0.0025 "%E" sprintf = ] unit-test
+[ t ] [ "2.500000E-03" 0.0025 "%E" sprintf = ] unit-test
[ t ] [ " 1.0E+01" 10 "%10.1E" sprintf = ] unit-test
! See http://factorcode.org/license.txt for BSD license
USING: io io.encodings.ascii io.files io.streams.string combinators
-kernel sequences splitting strings math math.parser macros
-fry peg.ebnf ascii unicode.case arrays quotations vectors ;
+kernel sequences splitting strings math math.functions math.parser
+macros fry peg.ebnf ascii unicode.case arrays quotations vectors ;
IN: printf
: >digits ( string -- digits )
[ 0 ] [ string>number ] if-empty ;
-: max-digits ( string digits -- string )
+: pad-digits ( string digits -- string' )
[ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." swap 3append ;
-: max-width ( string length -- string )
+: max-digits ( n digits -- n' )
+ 10 swap ^ [ * round ] keep / ;
+
+: max-width ( string length -- string' )
short head ;
-: >exponential ( n -- base exp )
- [ 0 < ] keep abs 0
- [ swap dup [ 10.0 >= ] keep 1.0 < or ]
- [ dup 10.0 >=
- [ 10.0 / [ 1+ ] dip swap ]
- [ 10.0 * [ 1- ] dip swap ] if
- ] [ swap ] while
- [ number>string ] dip
- dup abs number>string 2 CHAR: 0 pad-left
- [ 0 < "-" "+" ? ] dip append
- "e" prepend
- rot [ [ "-" prepend ] dip ] when ;
+: >exp ( x -- exp base )
+ [
+ abs 0 swap
+ [ dup [ 10.0 >= ] [ 1.0 < ] bi or ]
+ [ dup 10.0 >=
+ [ 10.0 / [ 1+ ] dip ]
+ [ 10.0 * [ 1- ] dip ] if
+ ] [ ] while
+ ] keep 0 < [ neg ] when ;
+
+: exp>string ( exp base digits -- string )
+ [ max-digits ] keep -rot
+ [
+ [ 0 < "-" "+" ? ]
+ [ abs number>string 2 CHAR: 0 pad-left ] bi
+ "e" -rot 3append
+ ]
+ [ number>string ] bi*
+ rot pad-digits prepend ;
EBNF: parse-format-string
zero = "0" => [[ CHAR: 0 ]]
char = "'" (.) => [[ second ]]
-pad-char = (zero|char)? => [[ CHAR: \s or 1quotation ]]
-pad-align = ("-")? => [[ [ pad-right ] [ pad-left ] ? ]]
-pad-width = ([0-9])* => [[ >digits 1quotation ]]
-pad = pad-align pad-char pad-width => [[ reverse compose-all [ first ] keep swap 0 = [ drop [ ] ] when ]]
+pad-char = (zero|char)? => [[ CHAR: \s or ]]
+pad-align = ("-")? => [[ \ pad-right \ pad-left ? ]]
+pad-width = ([0-9])* => [[ >digits ]]
+pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = [ drop [ ] ] when ]]
-sign = ("+")? => [[ [ dup CHAR: - swap index not [ "+" prepend ] when ] [ ] ? ]]
+sign = ("+")? => [[ [ dup CHAR: - swap index [ "+" prepend ] unless ] [ ] ? ]]
width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]]
width = (width_)? => [[ [ ] or ]]
-digits_ = "." ([0-9])* => [[ second >digits '[ _ max-digits ] ]]
-digits = (digits_)? => [[ [ ] or ]]
+digits_ = "." ([0-9])* => [[ second >digits ]]
+digits = (digits_)? => [[ 6 or ]]
fmt-% = "%" => [[ [ "%" ] ]]
fmt-c = "c" => [[ [ 1string ] ]]
fmt-s = "s" => [[ [ ] ]]
fmt-S = "S" => [[ [ >upper ] ]]
fmt-d = "d" => [[ [ >fixnum number>string ] ]]
-fmt-e = "e" => [[ [ >exponential ] ]]
-fmt-E = "E" => [[ [ >exponential >upper ] ]]
-fmt-f = "f" => [[ [ >float number>string ] ]]
+fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]]
+fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]]
+fmt-f = digits "f" => [[ first dup '[ >float _ max-digits number>string _ pad-digits ] ]]
fmt-x = "x" => [[ [ >hex ] ]]
fmt-X = "X" => [[ [ >hex >upper ] ]]
unknown = (.)* => [[ "Unknown directive" throw ]]
-chars = fmt-c | fmt-C
-strings = pad width (fmt-s|fmt-S) => [[ reverse compose-all ]]
-decimals = fmt-d
-exps = digits (fmt-e|fmt-E) => [[ reverse [ swap ] join [ swap append ] append ]]
-floats = digits fmt-f => [[ reverse compose-all ]]
-hex = fmt-x | fmt-X
-numbers = sign pad (decimals|floats|hex|exps) => [[ reverse first3 swap 3append [ fix-sign ] append ]]
+strings_ = fmt-c|fmt-C|fmt-s|fmt-S
+strings = pad width strings_ => [[ reverse compose-all ]]
+
+numbers_ = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X
+numbers = sign pad numbers_ => [[ unclip-last prefix compose-all [ fix-sign ] append ]]
-formats = "%" (chars|strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]]
+formats = "%" (strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]]
-plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
+plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
-text = (formats|plain-text)* => [[ reverse [ [ dup [ push ] dip ] append ] map ]]
+text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
;EBNF
! 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
! 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
! 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
: 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
! 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
! 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
! 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
! 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
! 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
! 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
! 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
! 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
! 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
! 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
! 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
! 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
! 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
: (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 ;
! 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
! 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
! 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
! 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
! 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
USING: circular disjoint-sets kernel math math.ranges
- sequences sequences.lib ;
+sequences ;
IN: project-euler.186
: (generator) ( k -- n )
! 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
[ t ] [ "ab" 4 strings [ >string ] map "abab" swap member? ] unit-test
[ { { } { 1 } { 2 } { 1 2 } } ] [ { 1 2 } power-set ] unit-test
-[ f ] [ { } ?first ] unit-test
-[ f ] [ { } ?fourth ] unit-test
-[ 1 ] [ { 1 2 3 } ?first ] unit-test
-[ 2 ] [ { 1 2 3 } ?second ] unit-test
-[ 3 ] [ { 1 2 3 } ?third ] unit-test
-[ f ] [ { 1 2 3 } ?fourth ] unit-test
-
[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
: power-set ( seq -- subsets )
2 over length exact-number-strings swap [ switches ] curry map ;
-: ?first ( seq -- first/f ) 0 swap ?nth ; inline
-: ?second ( seq -- second/f ) 1 swap ?nth ; inline
-: ?third ( seq -- third/f ) 2 swap ?nth ; inline
-: ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline
-
-: ?first2 ( seq -- 1st/f 2nd/f ) dup ?first swap ?second ; inline
-: ?first3 ( seq -- 1st/f 2nd/f 3rd/f ) dup ?first2 rot ?third ; inline
-: ?first4 ( seq -- 1st/f 2nd/f 3rd/f 4th/f ) dup ?first3 roll ?fourth ; inline
-
USE: continuations
: ?subseq ( from to seq -- subseq )
>r >r 0 max r> r>
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string urls
+multiline spider.private quotations ;
+IN: spider
+
+HELP: <spider>
+{ $values
+ { "base" "a string or url" }
+ { "spider" spider } }
+{ $description "Creates a new web spider with a given base url." } ;
+
+HELP: run-spider
+{ $values
+ { "spider" spider }
+ { "spider" spider } }
+{ $description "Runs a spider until completion. See the " { $subsection "spider-tutorial" } " for a complete description of the tuple slots that affect how thet spider works." } ;
+
+HELP: slurp-heap-while
+{ $values
+ { "heap" "a heap" } { "quot1" quotation } { "quot2" quotation } }
+{ $description "Removes values from a heap that match the predicate quotation " { $snippet "quot1" } " and processes them with " { $snippet "quot2" } " until the predicate quotation no longer matches." } ;
+
+ARTICLE: "spider-tutorial" "Spider tutorial"
+"To create a new spider, call the " { $link <spider> } " word with a link to the site you wish to spider."
+{ $code <" "http://concatentative.org" <spider> "> }
+"The max-depth is initialized to 0, which retrieves just the initial page. Let's initialize it to something more fun:"
+{ $code <" 1 >>max-depth "> }
+"Now the spider will retrieve the first page and all the pages it links to in the same domain." $nl
+"But suppose the front page contains thousands of links. To avoid grabbing them all, we can set " { $slot "max-count" } " to a reasonable limit."
+{ $code <" 10 >>max-count "> }
+"A timeout might keep the spider from hitting the server too hard:"
+{ $code <" USE: calendar 1.5 seconds >>sleep "> }
+"Since we happen to know that not all pages of a wiki are suitable for spidering, we will spider only the wiki view pages, not the edit or revisions pages. To do this, we add a filter through which new links are tested; links that pass the filter are added to the todo queue, while links that do not are discarded. You can add several filters to the filter array, but we'll just add a single one for now."
+{ $code <" { [ path>> "/wiki/view" head? ] } >>filters "> }
+"Finally, to start the spider, call the " { $link run-spider } " word."
+{ $code "run-spider" }
+"The full code from the tutorial."
+{ $code <" USING: spider calendar sequences accessors ;
+: spider-concatenative ( -- spider )
+ "http://concatenative.org" <spider>
+ 1 >>max-depth
+ 10 >>max-count
+ 1.5 seconds >>sleep
+ { [ path>> "/wiki/view" head? ] } >>filters
+ run-spider ;"> } ;
+
+ARTICLE: "spider" "Spider"
+"The " { $vocab-link "spider" } " vocabulary implements a simple web spider for retrieving sets of webpages."
+{ $subsection "spider-tutorial" }
+"Creating a new spider:"
+{ $subsection <spider> }
+"Running the spider:"
+{ $subsection run-spider } ;
+
+ABOUT: "spider"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors fry html.parser html.parser.analyzer
+http.client kernel tools.time sets assocs sequences
+concurrency.combinators io threads namespaces math multiline
+heaps math.parser inspector urls assoc-heaps logging
+combinators.short-circuit continuations calendar prettyprint ;
+IN: spider
+
+TUPLE: spider base count max-count sleep max-depth initial-links
+filters spidered todo nonmatching quiet ;
+
+TUPLE: spider-result url depth headers fetch-time parsed-html
+links processing-time timestamp ;
+
+: <spider> ( base -- spider )
+ >url
+ spider new
+ over >>base
+ swap 0 <unique-min-heap> [ heap-push ] keep >>todo
+ <unique-min-heap> >>nonmatching
+ 0 >>max-depth
+ 0 >>count
+ 1/0. >>max-count
+ H{ } clone >>spidered ;
+
+<PRIVATE
+
+: apply-filters ( links spider -- links' )
+ filters>> [ '[ _ 1&& ] filter ] when* ;
+
+: push-links ( links level assoc-heap -- )
+ '[ _ _ heap-push ] each ;
+
+: add-todo ( links level spider -- )
+ todo>> push-links ;
+
+: add-nonmatching ( links level spider -- )
+ nonmatching>> push-links ;
+
+: filter-base ( spider spider-result -- base-links nonmatching-links )
+ [ base>> host>> ] [ links>> prune ] bi*
+ [ host>> = ] with partition ;
+
+: add-spidered ( spider spider-result -- )
+ [ [ 1+ ] change-count ] dip
+ 2dup [ spidered>> ] [ dup url>> ] bi* rot set-at
+ [ filter-base ] 2keep
+ depth>> 1+ swap
+ [ add-nonmatching ]
+ [ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
+
+: normalize-hrefs ( links -- links' )
+ [ >url ] map
+ spider get base>> swap [ derive-url ] with map ;
+
+: print-spidering ( url depth -- )
+ "depth: " write number>string write
+ ", spidering: " write . yield ;
+
+: (spider-page) ( url depth -- spider-result )
+ f pick spider get spidered>> set-at
+ over '[ _ http-get ] benchmark swap
+ [ parse-html dup find-hrefs normalize-hrefs ] benchmark
+ now spider-result boa ;
+
+: spider-page ( url depth -- )
+ spider get quiet>> [ 2dup print-spidering ] unless
+ (spider-page)
+ spider get [ quiet>> [ dup describe ] unless ]
+ [ swap add-spidered ] bi ;
+
+\ spider-page ERROR add-error-logging
+
+: spider-sleep ( -- )
+ spider get sleep>> [ sleep ] when* ;
+
+: queue-initial-links ( spider -- spider )
+ [ initial-links>> normalize-hrefs 0 ] keep
+ [ add-todo ] keep ;
+
+: slurp-heap-while ( heap quot1 quot2: ( value key -- ) -- )
+ pick heap-empty? [ 3drop ] [
+ [ [ heap-pop dup ] 2dip slip [ t ] compose [ 2drop f ] if ]
+ [ roll [ slurp-heap-while ] [ 3drop ] if ] 3bi
+ ] if ; inline recursive
+
+PRIVATE>
+
+: run-spider ( spider -- spider )
+ "spider" [
+ dup spider [
+ queue-initial-links
+ [ todo>> ] [ max-depth>> ] bi
+ '[
+ _ <= spider get
+ [ count>> ] [ max-count>> ] bi < and
+ ] [ spider-page spider-sleep ] slurp-heap-while
+ spider get
+ ] with-variable
+ ] with-logging ;
--- /dev/null
+Marc Fauconneau
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays help.markup help.syntax io.streams.string
+sequences strings math suffix-arrays.private ;
+IN: suffix-arrays
+
+HELP: >suffix-array
+{ $values
+ { "seq" sequence }
+ { "array" array } }
+{ $description "Creates a suffix array from the input sequence. Suffix arrays are arrays of slices." } ;
+
+HELP: SA{
+{ $description "Creates a new literal suffix array at parse-time." } ;
+
+HELP: suffixes
+{ $values
+ { "string" string }
+ { "suffixes-seq" "a sequence of slices" } }
+{ $description "Returns a sequence of tail slices of the input string." } ;
+
+HELP: from-to
+{ $values
+ { "index" integer } { "begin" sequence } { "suffix-array" "a suffix-array" }
+ { "from/f" "an integer or f" } { "to/f" "an integer or f" } }
+{ $description "Finds the bounds of the suffix array that match the input sequence. A return value of " { $link f } " means that the endpoint is included." }
+{ $notes "Slices are [m,n) and we want (m,n) so we increment." } ;
+
+HELP: query
+{ $values
+ { "begin" sequence } { "suffix-array" "a suffix-array" }
+ { "matches" array } }
+{ $description "Returns a sequence of sequences from the suffix-array that contain the input sequence. An empty array is returned when there are no matches." } ;
+
+ARTICLE: "suffix-arrays" "Suffix arrays"
+"The " { $vocab-link "suffix-arrays" } " vocabulary implements the suffix array data structure for efficient lookup of subsequences. This suffix array implementation is a sorted array of suffixes. Querying it for matches uses binary search for efficiency." $nl
+
+"Creating new suffix arrays:"
+{ $subsection >suffix-array }
+"Literal suffix arrays:"
+{ $subsection POSTPONE: SA{ }
+"Querying suffix arrays:"
+{ $subsection query } ;
+
+ABOUT: "suffix-arrays"
--- /dev/null
+! Copyright (C) 2008 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test suffix-arrays kernel namespaces sequences ;
+IN: suffix-arrays.tests
+
+! built from [ all-words 10 head [ name>> ] map ]
+[ ] [
+ {
+ "run-tests"
+ "must-fail-with"
+ "test-all"
+ "short-effect"
+ "failure"
+ "test"
+ "<failure>"
+ "this-test"
+ "(unit-test)"
+ "unit-test"
+ } >suffix-array "suffix-array" set
+] unit-test
+
+[ t ]
+[ "suffix-array" get "" swap query empty? not ] unit-test
+
+[ { } ]
+[ SA{ } "something" swap query ] unit-test
+
+[ V{ "unit-test" "(unit-test)" } ]
+[ "suffix-array" get "unit-test" swap query ] unit-test
+
+[ t ]
+[ "suffix-array" get "something else" swap query empty? ] unit-test
+
+[ V{ "rofl" } ] [ SA{ "rofl" } "r" swap query ] unit-test
+[ V{ "rofl" } ] [ SA{ "rofl" } "o" swap query ] unit-test
+[ V{ "rofl" } ] [ SA{ "rofl" } "f" swap query ] unit-test
+[ V{ "rofl" } ] [ SA{ "rofl" } "l" swap query ] unit-test
+[ V{ } ] [ SA{ "rofl" } "t" swap query ] unit-test
--- /dev/null
+! Copyright (C) 2008 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser kernel arrays math accessors sequences
+math.vectors math.order sorting binary-search sets assocs fry ;
+IN: suffix-arrays
+
+<PRIVATE
+: suffixes ( string -- suffixes-seq )
+ dup length [ tail-slice ] with map ;
+
+: prefix<=> ( begin seq -- <=> )
+ [ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ;
+
+: find-index ( begin suffix-array -- index/f )
+ [ prefix<=> ] with search drop ;
+
+: from-to ( index begin suffix-array -- from/f to/f )
+ swap '[ _ head? not ]
+ [ find-last-from drop dup [ 1+ ] when ]
+ [ find-from drop ] 3bi ;
+
+: <funky-slice> ( from/f to/f seq -- slice )
+ [
+ tuck
+ [ drop 0 or ] [ length or ] 2bi*
+ [ min ] keep
+ ] keep <slice> ; inline
+
+PRIVATE>
+
+: >suffix-array ( seq -- array )
+ [ suffixes ] map concat natural-sort ;
+
+: SA{ \ } [ >suffix-array ] parse-literal ; parsing
+
+: query ( begin suffix-array -- matches )
+ 2dup find-index dup
+ [ -rot [ from-to ] keep <funky-slice> [ seq>> ] map prune ]
+ [ 3drop { } ] if ;
--- /dev/null
+Suffix arrays
--- /dev/null
+collections
--- /dev/null
+! Copyright (C) 2008 Marc Fauconneau.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel arrays math accessors sequences math.vectors\r
+math.order sorting binary-search sets assocs fry suffix-arrays ;\r
+IN: suffix-arrays.words\r
+\r
+! to search on word names\r
+\r
+: new-word-sa ( words -- sa )\r
+ [ name>> ] map >suffix-array ;\r
+\r
+: name>word-map ( words -- map )\r
+ dup [ name>> V{ } clone ] H{ } map>assoc\r
+ [ '[ dup name>> _ at push ] each ] keep ;\r
+\r
+: query-word-sa ( map begin sa -- matches ) query '[ _ at ] map concat ;\r
+\r
+! usage example :\r
+! clear all-words 100 head dup name>word-map "test" rot new-word-sa query .\r
--- /dev/null
+! 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 - ;
--- /dev/null
+! 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 * ;
--- /dev/null
+! 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 -
+ * ;
--- /dev/null
+! 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 * ;
--- /dev/null
+! 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 ;
--- /dev/null
+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
+] [
+ 12000 2008 3 f <w4> <federal> net biweekly
+ dollars/cents
+] unit-test
+
+[
+ 426 23
+] [
+ 12000 2008 3 t <w4> <federal> net biweekly
+ dollars/cents
+] unit-test
+
+[
+ 684 4
+] [
+ 20000 2008 3 f <w4> <federal> net biweekly
+ dollars/cents
+] unit-test
+
+
+
+[
+ 804 58
+] [
+ 24000 2008 3 f <w4> <federal> net biweekly
+ dollars/cents
+] unit-test
+
+[
+ 831 31
+] [
+ 24000 2008 3 t <w4> <federal> net biweekly
+ dollars/cents
+] unit-test
+
+
+[
+ 780 81
+] [
+ 24000 2008 3 f <w4> <mn> net biweekly
+ dollars/cents
+] unit-test
+
+[
+ 818 76
+] [
+ 24000 2008 3 t <w4> <mn> net biweekly
+ dollars/cents
+] unit-test
+
+
+[
+ 2124 39
+] [
+ 78250 2008 3 f <w4> <mn> net biweekly
+ dollars/cents
+] unit-test
+
+[
+ 2321 76
+] [
+ 78250 2008 3 t <w4> <mn> net biweekly
+ dollars/cents
+] unit-test
+
+
+[
+ 2612 63
+] [
+ 100000 2008 3 f <w4> <mn> net biweekly
+ dollars/cents
+] unit-test
+
+[
+ 22244 52
+] [
+ 1000000 2008 3 f <w4> <mn> net biweekly
+ dollars/cents
+] unit-test
+
+[
+ 578357 40
+] [
+ 1000000 2008 3 f <w4> <mn> net
+ dollars/cents
+] unit-test
+
+[
+ 588325 41
+] [
+ 1000000 2008 3 t <w4> <mn> net
+ dollars/cents
+] unit-test
+
+
+[ 30 97 ] [
+ 24000 2008 2 f <w4> <mn> MN withholding* biweekly dollars/cents
+] unit-test
+
+[ 173 66 ] [
+ 78250 2008 2 f <w4> <mn> MN withholding* biweekly dollars/cents
+] unit-test
+
+
+[ 138 69 ] [
+ 24000 2008 2 f <w4> <federal> total-withholding biweekly dollars/cents
+] unit-test
+
+[ 754 72 ] [
+ 78250 2008 2 f <w4> <federal> total-withholding biweekly dollars/cents
+] unit-test
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 * ;
+
--- /dev/null
+! 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 / ;
counter-app new-dispatcher
[ 1+ ] <counter-action> "inc" add-responder
[ 1- ] <counter-action> "dec" add-responder
- <display-action> "" add-responder
- <sessions> ;
+ <display-action> "" add-responder ;
! Deployment example
USING: db.sqlite furnace.alloy namespaces ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors http.server.dispatchers
+http.server.static furnace.actions furnace.redirection urls
+validators locals io.files html.forms help.html ;
+IN: webapps.help
+
+TUPLE: help-webapp < dispatcher ;
+
+:: <search-action> ( help-dir -- action )
+ <page-action>
+ { help-webapp "search" } >>template
+
+ [
+ {
+ { "search" [ 1 v-min-length 50 v-max-length v-one-line ] }
+ } validate-params
+
+ help-dir set-current-directory
+
+ "search" value article-apropos "articles" set-value
+ "search" value word-apropos "words" set-value
+ "search" value vocab-apropos "vocabs" set-value
+
+ { help-webapp "search" } <chloe-content>
+ ] >>submit ;
+
+: <main-action> ( -- action )
+ <page-action>
+ { help-webapp "help" } >>template ;
+
+: <help-webapp> ( help-dir -- webapp )
+ help-webapp new-dispatcher
+ <main-action> "" add-responder
+ over <search-action> "search" add-responder
+ swap <static> "content" add-responder ;
+
+
--- /dev/null
+<?xml version="1.0"?>
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd">
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title>Factor Documentation</title>
+ <t:base t:href="$help-webapp" />
+ </head>
+
+ <frameset cols="30%, 70%">
+ <frame src="search" name="search" />
+ <frame src="content/article-handbook.html" name="content" />
+ </frameset>
+ </html>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <t:base t:href="$help-webapp/content/" />
+
+ <style>
+ body { font-family: sans-serif; font-size: 85%; }
+ a:link { text-decoration: none; color: #00004c; }
+ a:visited { text-decoration: none; color: #00004c; }
+ a:active { text-decoration: none; color: #00004c; }
+ a:hover { text-decoration: underline; color: #00004c; }
+ </style>
+ </head>
+
+ <body>
+ <h1><t:a t:href="$help-webapp/content/article-handbook.html"
+ target="content">Factor documentation</t:a></h1>
+
+ <p>This is the <a href="http://factorcode.org" target="_top">Factor</a>
+ documentation, generated offline from a
+ <code>load-everything</code> image. If you want, you can also browse the
+ documentation from within the <a href="http://factorcode.org" target="_top">Factor</a> UI.</p>
+
+ <p>You may search article titles below; for example, try searching for "HTTP".</p>
+
+ <t:form t:action="$help-webapp/search">
+ <t:field t:name="search" />
+ <button>Search</button>
+ </t:form>
+
+ <t:if t:value="articles">
+ <hr/>
+
+ <h2>Articles</h2>
+
+ <ul>
+ <t:each t:name="articles">
+ <li> <t:link t:name="value" t:target="content" /> </li>
+ </t:each>
+ </ul>
+ </t:if>
+
+ <t:if t:value="vocabs">
+ <hr/>
+
+ <h2>Vocabularies</h2>
+
+ <ul>
+ <t:each t:name="vocabs">
+ <li> <t:link t:name="value" t:target="content" /> </li>
+ </t:each>
+ </ul>
+ </t:if>
+
+ <t:if t:value="words">
+ <hr/>
+
+ <h2>Words</h2>
+
+ <ul>
+ <t:each t:name="words">
+ <li> <t:link t:name="value" t:target="content" /> </li>
+ </t:each>
+ </ul>
+ </t:if>
+
+ </body>
+</html>
+
+</t:chloe>
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar kernel http.server.dispatchers prettyprint
+sequences printf furnace.actions html.forms accessors
+furnace.redirection ;
+IN: webapps.irc-log
+
+TUPLE: irclog-app < dispatcher ;
+
+: irc-link ( -- string )
+ gmt -7 hours convert-timezone >date<
+ [ unparse 2 tail ] 2dip
+ "http://bespin.org/~nef/logs/concatenative/%02s.%02d.%02d"
+ sprintf ;
+
+: <display-irclog-action> ( -- action )
+ <action>
+ [ irc-link <redirect> ] >>display ;
+
+: <irclog-app> ( -- dispatcher )
+ irclog-app new-dispatcher
+ <display-irclog-action> "" add-responder ;
</tr>
</table>
- <input type="SUBMIT" value="Submit" />
+ <p> <button>Submit</button> </p>
</t:form>
</t:chloe>
<t:bind-each t:name="annotations">
- <a name="@id"><h2>Annotation: <t:label t:name="summary" /></h2></a>
+ <h2><a name="@id">Annotation: <t:label t:name="summary" /></a></h2>
<table>
<tr><th class="field-label">Author: </th><td><t:label t:name="author" /></td></tr>
</tr>
</table>
- <input type="SUBMIT" value="Done" />
+ <p> <button>Done</button> </p>
</t:form>
<div class="navbar">
- <t:a t:href="$pastebin/list">Pastes</t:a>
+ <t:a t:href="$pastebin">Pastes</t:a>
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
<t:if t:code="furnace.auth:logged-in?">
[
f <blog>
[ deposit-blog-slots ]
+ [ "id" value >>id ]
[ update-tuple ]
- [
- <url>
- "$planet/admin" >>path
- swap id>> "id" set-query-param
- <redirect>
- ]
tri
+
+ <url>
+ "$planet/admin" >>path
+ "id" value "id" set-query-param
+ <redirect>
] >>submit ;
: <planet-admin> ( -- responder )
<boilerplate>
{ planet "planet-common" } >>template ;
-: start-update-task ( db params -- )
- '[ _ _ [ update-cached-postings ] with-db ] 10 minutes every drop ;
+: start-update-task ( db -- )
+ '[ _ [ update-cached-postings ] with-db ] 10 minutes every drop ;
http.server
http.server.dispatchers
http.server.redirection
+http.server.static
+http.server.cgi
furnace.alloy
furnace.auth.login
furnace.auth.providers.db
webapps.pastebin
webapps.planet
webapps.wiki
-webapps.user-admin ;
+webapps.user-admin
+webapps.help ;
IN: websites.concatenative
-: test-db ( -- params db ) "resource:test.db" sqlite-db ;
+: test-db ( -- db ) "resource:test.db" <sqlite-db> ;
: init-factor-db ( -- )
test-db [
TUPLE: factor-website < dispatcher ;
-: <configuration> ( responder -- responder' )
+: <factor-boilerplate> ( responder -- responder' )
+ <boilerplate>
+ { factor-website "page" } >>template ;
+
+: <login-config> ( responder -- responder' )
"Factor website" <login-realm>
"Factor website" >>name
allow-registration
allow-password-recovery
allow-edit-profile
- allow-deactivation
- <boilerplate>
- { factor-website "page" } >>template
- test-db <alloy> ;
+ allow-deactivation ;
: <factor-website> ( -- responder )
factor-website new-dispatcher
"password" key-password set-global
common-configuration
<factor-website>
- <pastebin> "pastebin" add-responder
- <planet> "planet" add-responder
- <configuration>
+ <pastebin> <factor-boilerplate> <login-config> "pastebin" add-responder
+ <planet> <factor-boilerplate> <login-config> "planet" add-responder
+ "/tmp/docs/" <help-webapp> "docs" add-responder
+ test-db <alloy>
main-responder set-global ;
+: <gitweb> ( path -- responder )
+ <dispatcher>
+ swap <static> enable-cgi >>default
+ URL" /gitweb.cgi" <redirect-responder> "" add-responder ;
+
: init-production ( -- )
common-configuration
<vhost-dispatcher>
- <factor-website> "concatenative.org" add-responder
- <pastebin> "paste.factorcode.org" add-responder
- <planet> "planet.factorcode.org" add-responder
- <configuration>
+ <factor-website> <login-config> <factor-boilerplate> test-db <alloy> "concatenative.org" add-responder
+ <pastebin> <login-config> <factor-boilerplate> test-db <alloy> "paste.factorcode.org" add-responder
+ <planet> <login-config> <factor-boilerplate> test-db <alloy> "planet.factorcode.org" add-responder
+ home "docs" append-path <help-webapp> test-db <alloy> "docs.factorcode.org" add-responder
+ home "cgi" append-path <gitweb> "gitweb.factorcode.org" add-responder
main-responder set-global ;
: <factor-secure-config> ( -- config )
--- /dev/null
+USING: kernel namespaces db.sql sequences math ;
+IN: db.sql.tests
+
+! TUPLE: person name age ;
+: insert-1
+ { insert
+ {
+ { table "person" }
+ { columns "name" "age" }
+ { values "erg" 26 }
+ }
+ } ;
+
+: update-1
+ { update "person"
+ { set { "name" "erg" }
+ { "age" 6 } }
+ { where { "age" 6 } }
+ } ;
+
+: select-1
+ { select
+ { columns
+ "branchno"
+ { count "staffno" as "mycount" }
+ { sum "salary" as "mysum" } }
+ { from "staff" "lol" }
+ { where
+ { "salary" > all
+ { select
+ { columns "salary" }
+ { from "staff" }
+ { where { "branchno" = "b003" } }
+ }
+ }
+ { "branchno" > 3 } }
+ { group-by "branchno" "lol2" }
+ { having { count "staffno" > 1 } }
+ { order-by "branchno" }
+ { offset 40 }
+ { limit 20 }
+ } ;
--- /dev/null
+USING: kernel parser quotations classes.tuple words math.order
+nmake namespaces sequences arrays combinators
+prettyprint strings math.parser math symbols db ;
+IN: db.sql
+
+SYMBOLS: insert update delete select distinct columns from as
+where group-by having order-by limit offset is-null desc all
+any count avg table values ;
+
+: input-spec, ( obj -- ) 1, ;
+: output-spec, ( obj -- ) 2, ;
+: input, ( obj -- ) 3, ;
+: output, ( obj -- ) 4, ;
+
+DEFER: sql%
+
+: (sql-interleave) ( seq sep -- )
+ [ sql% ] curry [ sql% ] interleave ;
+
+: sql-interleave ( seq str sep -- )
+ swap sql% (sql-interleave) ;
+
+: sql-function, ( seq function -- )
+ sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
+
+: sql-where, ( seq -- )
+ [
+ [ second 0, ]
+ [ first 0, ]
+ [ third 1, \ ? 0, ] tri
+ ] each ;
+
+HOOK: sql-create db ( object -- )
+M: db sql-create ( object -- )
+ drop
+ "create table" sql% ;
+
+HOOK: sql-drop db ( object -- )
+M: db sql-drop ( object -- )
+ drop
+ "drop table" sql% ;
+
+HOOK: sql-insert db ( object -- )
+M: db sql-insert ( object -- )
+ drop
+ "insert into" sql% ;
+
+HOOK: sql-update db ( object -- )
+M: db sql-update ( object -- )
+ drop
+ "update" sql% ;
+
+HOOK: sql-delete db ( object -- )
+M: db sql-delete ( object -- )
+ drop
+ "delete" sql% ;
+
+HOOK: sql-select db ( object -- )
+M: db sql-select ( object -- )
+ "select" sql% "," (sql-interleave) ;
+
+HOOK: sql-columns db ( object -- )
+M: db sql-columns ( object -- )
+ "," (sql-interleave) ;
+
+HOOK: sql-from db ( object -- )
+M: db sql-from ( object -- )
+ "from" "," sql-interleave ;
+
+HOOK: sql-where db ( object -- )
+M: db sql-where ( object -- )
+ "where" 0, sql-where, ;
+
+HOOK: sql-group-by db ( object -- )
+M: db sql-group-by ( object -- )
+ "group by" "," sql-interleave ;
+
+HOOK: sql-having db ( object -- )
+M: db sql-having ( object -- )
+ "having" "," sql-interleave ;
+
+HOOK: sql-order-by db ( object -- )
+M: db sql-order-by ( object -- )
+ "order by" "," sql-interleave ;
+
+HOOK: sql-offset db ( object -- )
+M: db sql-offset ( object -- )
+ "offset" sql% sql% ;
+
+HOOK: sql-limit db ( object -- )
+M: db sql-limit ( object -- )
+ "limit" sql% sql% ;
+
+! GENERIC: sql-subselect db ( object -- )
+! M: db sql-subselectselect ( object -- )
+ ! "(select" sql% sql% ")" sql% ;
+
+HOOK: sql-table db ( object -- )
+M: db sql-table ( object -- )
+ sql% ;
+
+HOOK: sql-set db ( object -- )
+M: db sql-set ( object -- )
+ "set" "," sql-interleave ;
+
+HOOK: sql-values db ( object -- )
+M: db sql-values ( object -- )
+ "values(" sql% "," (sql-interleave) ")" sql% ;
+
+HOOK: sql-count db ( object -- )
+M: db sql-count ( object -- )
+ "count" sql-function, ;
+
+HOOK: sql-sum db ( object -- )
+M: db sql-sum ( object -- )
+ "sum" sql-function, ;
+
+HOOK: sql-avg db ( object -- )
+M: db sql-avg ( object -- )
+ "avg" sql-function, ;
+
+HOOK: sql-min db ( object -- )
+M: db sql-min ( object -- )
+ "min" sql-function, ;
+
+HOOK: sql-max db ( object -- )
+M: db sql-max ( object -- )
+ "max" sql-function, ;
+
+: sql-array% ( array -- )
+ unclip
+ {
+ { \ create [ sql-create ] }
+ { \ drop [ sql-drop ] }
+ { \ insert [ sql-insert ] }
+ { \ update [ sql-update ] }
+ { \ delete [ sql-delete ] }
+ { \ select [ sql-select ] }
+ { \ columns [ sql-columns ] }
+ { \ from [ sql-from ] }
+ { \ where [ sql-where ] }
+ { \ group-by [ sql-group-by ] }
+ { \ having [ sql-having ] }
+ { \ order-by [ sql-order-by ] }
+ { \ offset [ sql-offset ] }
+ { \ limit [ sql-limit ] }
+ { \ table [ sql-table ] }
+ { \ set [ sql-set ] }
+ { \ values [ sql-values ] }
+ { \ count [ sql-count ] }
+ { \ sum [ sql-sum ] }
+ { \ avg [ sql-avg ] }
+ { \ min [ sql-min ] }
+ { \ max [ sql-max ] }
+ [ sql% [ sql% ] each ]
+ } case ;
+
+ERROR: no-sql-match ;
+: sql% ( obj -- )
+ {
+ { [ dup string? ] [ 0, ] }
+ { [ dup array? ] [ sql-array% ] }
+ { [ dup number? ] [ number>string sql% ] }
+ { [ dup symbol? ] [ unparse sql% ] }
+ { [ dup word? ] [ unparse sql% ] }
+ { [ dup quotation? ] [ call ] }
+ [ no-sql-match ]
+ } cond ;
+
+: parse-sql ( obj -- sql in-spec out-spec in out )
+ [ [ sql% ] each ] { { } { } { } } nmake
+ [ " " join ] 2dip ;
+++ /dev/null
-USING: assocs assoc-heaps heaps heaps.private kernel tools.test ;
-IN: temporary
-
-[
-T{
- assoc-heap
- f
- H{ { 2 1 } }
- T{ min-heap T{ heap f V{ { 1 2 } } } }
-}
-] [ H{ } clone <assoc-min-heap> 1 2 pick heap-push ] unit-test
-
-[
-T{
- assoc-heap
- f
- H{ { 1 0 } { 2 1 } }
- T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } }
-}
-] [ H{ } clone <assoc-min-heap> 1 2 pick heap-push 0 1 pick heap-push ] unit-test
-
-[ T{ assoc-heap f H{ } T{ min-heap T{ heap f V{ } } } } ]
-[
- H{ } clone <assoc-min-heap>
- 1 2 pick heap-push 0 1 pick heap-push
- dup heap-pop 2drop dup heap-pop 2drop
-] unit-test
-
-
-[ 0 1 ] [
-T{
- assoc-heap
- f
- H{ { 1 0 } { 2 1 } }
- T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } }
-} heap-pop
-] unit-test
-
-[ 1 2 ] [
-T{
- assoc-heap
- f
- H{ { 1 0 } { 2 1 } }
- T{ max-heap T{ heap f V{ { 1 2 } { 0 1 } } } }
-} heap-pop
-] unit-test
-
-[
-T{
- assoc-heap
- f
- H{ { 1 2 } { 3 4 } }
- T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } } } }
-}
-] [ H{ { 1 2 } { 3 4 } } H{ } clone <assoc-min-heap> [ heap-push-all ] keep ] unit-test
+++ /dev/null
-USING: assocs heaps kernel sequences ;
-IN: assoc-heaps
-
-TUPLE: assoc-heap assoc heap ;
-
-INSTANCE: assoc-heap assoc
-INSTANCE: assoc-heap priority-queue
-
-C: <assoc-heap> assoc-heap
-
-: <assoc-min-heap> ( assoc -- obj ) <min-heap> <assoc-heap> ;
-: <assoc-max-heap> ( assoc -- obj ) <max-heap> <assoc-heap> ;
-
-M: assoc-heap at* ( key assoc-heap -- value ? )
- assoc-heap-assoc at* ;
-
-M: assoc-heap assoc-size ( assoc-heap -- n )
- assoc-heap-assoc assoc-size ;
-
-TUPLE: assoc-heap-key-exists ;
-
-: check-key-exists ( key assoc-heap -- )
- assoc-heap-assoc key?
- [ \ assoc-heap-key-exists construct-empty throw ] when ;
-
-M: assoc-heap set-at ( value key assoc-heap -- )
- [ check-key-exists ] 2keep
- [ assoc-heap-assoc set-at ] 3keep
- assoc-heap-heap swapd heap-push ;
-
-M: assoc-heap heap-empty? ( assoc-heap -- ? )
- assoc-heap-assoc assoc-empty? ;
-
-M: assoc-heap heap-length ( assoc-heap -- n )
- assoc-heap-assoc assoc-size ;
-
-M: assoc-heap heap-peek ( assoc-heap -- value key )
- assoc-heap-heap heap-peek ;
-
-M: assoc-heap heap-push ( value key assoc-heap -- )
- set-at ;
-
-M: assoc-heap heap-pop ( assoc-heap -- value key )
- dup assoc-heap-heap heap-pop swap
- rot dupd assoc-heap-assoc delete-at ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Priority search queues
USING: accessors alien alien.accessors arrays assocs
combinators.lib io kernel macros math namespaces prettyprint
quotations sequences vectors vocabs words html.elements sets
-slots.private combinators.short-circuit ;
+slots.private combinators.short-circuit math.order hashtables
+sequences.deep ;
IN: lint
SYMBOL: def-hash
SYMBOL: def-hash-keys
: set-hash-vector ( val key hash -- )
- 2dup at -rot >r >r ?push r> r> set-at ;
+ 2dup at -rot [ ?push ] 2dip set-at ;
: add-word-def ( word quot -- )
dup callable? [
! Remove constants [ 1 ]
[
- drop dup length 1 = swap first number? and not
+ drop { [ length 1 = ] [ first number? ] } 1&& not
] assoc-filter
! Remove set-alien-cell, etc.
drop trivial-defs member? not
] assoc-filter
+[
+ drop {
+ [ [ wrapper? ] deep-contains? ]
+ [ [ hashtable? ] deep-contains? ]
+ } 1|| not
+] assoc-filter
+
! Remove n m shift defs
[
drop dup length 3 = [
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Calculate federal and state tax withholdings
+++ /dev/null
-USING: kernel money taxes tools.test ;
-IN: taxes.tests
-
-[
- 426 23
-] [
- 12000 2008 3 f <w4> <federal> net biweekly
- dollars/cents
-] unit-test
-
-[
- 426 23
-] [
- 12000 2008 3 t <w4> <federal> net biweekly
- dollars/cents
-] unit-test
-
-[
- 684 4
-] [
- 20000 2008 3 f <w4> <federal> net biweekly
- dollars/cents
-] unit-test
-
-
-
-[
- 804 58
-] [
- 24000 2008 3 f <w4> <federal> net biweekly
- dollars/cents
-] unit-test
-
-[
- 831 31
-] [
- 24000 2008 3 t <w4> <federal> net biweekly
- dollars/cents
-] unit-test
-
-
-[
- 780 81
-] [
- 24000 2008 3 f <w4> <minnesota> net biweekly
- dollars/cents
-] unit-test
-
-[
- 818 76
-] [
- 24000 2008 3 t <w4> <minnesota> net biweekly
- dollars/cents
-] unit-test
-
-
-[
- 2124 39
-] [
- 78250 2008 3 f <w4> <minnesota> net biweekly
- dollars/cents
-] unit-test
-
-[
- 2321 76
-] [
- 78250 2008 3 t <w4> <minnesota> net biweekly
- dollars/cents
-] unit-test
-
-
-[
- 2612 63
-] [
- 100000 2008 3 f <w4> <minnesota> net biweekly
- dollars/cents
-] unit-test
-
-[
- 22244 52
-] [
- 1000000 2008 3 f <w4> <minnesota> net biweekly
- dollars/cents
-] unit-test
-
-[
- 578357 40
-] [
- 1000000 2008 3 f <w4> <minnesota> net
- dollars/cents
-] unit-test
-
-[
- 588325 41
-] [
- 1000000 2008 3 t <w4> <minnesota> net
- dollars/cents
-] unit-test
-
-
-[ 30 97 ] [
- 24000 2008 2 f <w4> <minnesota> withholding biweekly dollars/cents
-] unit-test
-
-[ 173 66 ] [
- 78250 2008 2 f <w4> <minnesota> withholding biweekly dollars/cents
-] unit-test
-
-
-[ 138 69 ] [
- 24000 2008 2 f <w4> <federal> withholding biweekly dollars/cents
-] unit-test
-
-[ 754 72 ] [
- 78250 2008 2 f <w4> <federal> withholding biweekly dollars/cents
-] unit-test
+++ /dev/null
-! 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 - ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel furnace furnace.validator http.server.responders
- help help.topics html splitting sequences words strings
- quotations macros vocabs tools.browser combinators
- arrays io.files ;
-IN: webapps.help
-
-! : string>topic ( string -- topic )
- ! " " split dup length 1 = [ first ] when ;
-
-: show-help ( topic -- )
- serving-html
- dup article-title [
- [ help ] with-html-stream
- ] simple-html-document ;
-
-\ show-help {
- { "topic" }
-} define-action
-\ show-help { { "topic" "handbook" } } default-values
-
-M: link browser-link-href
- link-name
- dup word? over f eq? or [
- browser-link-href
- ] [
- dup array? [ " " join ] when
- [ show-help ] curry quot-link
- ] if ;
-
-: show-word ( word vocab -- )
- lookup show-help ;
-
-\ show-word {
- { "word" }
- { "vocab" }
-} define-action
-\ show-word { { "word" "call" } { "vocab" "kernel" } } default-values
-
-M: f browser-link-href
- drop \ f browser-link-href ;
-
-M: word browser-link-href
- dup word-name swap word-vocabulary
- [ show-word ] 2curry quot-link ;
-
-: show-vocab ( vocab -- )
- f >vocab-link show-help ;
-
-\ show-vocab {
- { "vocab" }
-} define-action
-
-\ show-vocab { { "vocab" "kernel" } } default-values
-
-M: vocab-spec browser-link-href
- vocab-name [ show-vocab ] curry quot-link ;
-
-: show-vocabs-tagged ( tag -- )
- <vocab-tag> show-help ;
-
-\ show-vocabs-tagged {
- { "tag" }
-} define-action
-
-M: vocab-tag browser-link-href
- vocab-tag-name [ show-vocabs-tagged ] curry quot-link ;
-
-: show-vocabs-by ( author -- )
- <vocab-author> show-help ;
-
-\ show-vocabs-by {
- { "author" }
-} define-action
-
-M: vocab-author browser-link-href
- vocab-author-name [ show-vocabs-by ] curry quot-link ;
-
-"help" "show-help" "extra/webapps/help" web-app
-
-! Hard-coding for factorcode.org
-PREDICATE: pathname resource-pathname
- pathname-string "resource:" head? ;
-
-M: resource-pathname browser-link-href
- pathname-string
- "resource:" ?head drop
- "/responder/source/" swap append ;
+++ /dev/null
-<% USING: io math math.parser namespaces furnace ; %>
-
-<h1>Annotate</h1>
-
-<form method="POST" action="/responder/pastebin/annotate-paste">
-
-<table>
-
-<tr>
-<th align="right">Summary:</th>
-<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
-<td align="left" class="error"><% "summary" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">Your name:</th>
-<td><input type="TEXT" name="author" value="<% "author" render %>" /></td>
-<td class="error"><% "author" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">File type:</th>
-<td><% "modes" render-template %></td>
-</tr>
-
-<!--
-<tr>
-<th align="right">Channel:</th>
-<td><input type="TEXT" name="channel" value="#concatenative" /></td>
-</tr>
--->
-
-<tr>
-<td></td>
-<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right" valign="top">Content:</th>
-<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
-</tr>
-</table>
-
-<input type="hidden" name="n" value="<% "n" get number>string write %>" />
-<input type="hidden" name="furnace-form-submitted" value="annotate-paste"/>
-<input type="SUBMIT" value="Annotate" />
-</form>
+++ /dev/null
-<% USING: namespaces io furnace calendar ; %>
-
-<h2>Annotation: <% "summary" get write %></h2>
-
-<table>
-<tr><th align="right">Annotation by:</th><td><% "author" get write %></td></tr>
-<tr><th align="right">File type:</th><td><% "mode" get write %></td></tr>
-<tr><th align="right">Created:</th><td><% "date" get timestamp>string write %></td></tr>
-</table>
-
-<% "syntax" render-template %>
+++ /dev/null
-Slava Pestov
+++ /dev/null
-</body>
-
-</html>
+++ /dev/null
-<% USING: namespaces io furnace sequences xmode.code2html webapps.pastebin ; %>
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
-<html xmlns="http://www.w3.org/1999/xhtml">
-<head>
- <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
-
- <title><% "title" get write %></title>
- <link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
- <% default-stylesheet %>
- <link rel="alternate" type="application/atom+xml" title="Pastebin - Atom" href="feed.xml" />
-</head>
-
-<body id="index">
-
- <div class="navbar">
- <% [ paste-list ] "Paste list" render-link %> |
- <% [ new-paste ] "New paste" render-link %> |
- <% [ feed.xml ] "Syndicate" render-link %>
- </div>
- <h1 class="pastebin-title"><% "title" get write %></h1>
+++ /dev/null
-<% USING: furnace xmode.catalog sequences kernel html.elements assocs io sorting continuations ; %>
-
-<select name="mode">
- <% modes keys natural-sort [
- <option dup "mode" session-var = [ "true" =selected ] when option> write </option>
- ] each %>
-</select>
+++ /dev/null
-<% USING: continuations furnace namespaces ; %>
-
-<%
- "New paste" "title" set
- "header" render-template
-%>
-
-<form method="POST" action="/responder/pastebin/submit-paste">
-
-<table>
-
-<tr>
-<th align="right">Summary:</th>
-<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
-<td align="left" class="error"><% "summary" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">Your name:</th>
-<td><input type="TEXT" name="author" value="<% "author" render %>" /></td>
-<td class="error"><% "author" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">File type:</th>
-<td><% "modes" render-template %></td>
-</tr>
-
-<!--
-<tr>
-<th align="right">Channel:</th>
-<td><input type="TEXT" name="channel" value="#concatenative" /></td>
-</tr>
--->
-
-<tr>
-<td></td>
-<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right" valign="top">Content:</th>
-<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
-</tr>
-</table>
-
-<input type="hidden" name="furnace-form-submitted" value="new-paste"/>
-<input type="SUBMIT" value="Submit paste" />
-</form>
-
-<% "footer" render-template %>
+++ /dev/null
-<% USING: namespaces furnace sequences ; %>
-
-<%
- "Pastebin" "title" set
- "header" render-template
-%>
-
-<table width="100%" cellspacing="10">
- <tr>
- <td valign="top">
- <table width="100%">
- <tr align="left" class="pastebin-headings">
- <th width="50%">Summary:</th>
- <th width="100">Paste by:</th>
- <th width="200">Date:</th>
- </tr>
- <% "pastes" get <reversed> [ "paste-summary" render-component ] each %>
- </table>
- </td>
- <td valign="top" width="25%">
- <div class="infobox">
- <p>This pastebin is written in <a href="http://factorcode.org/">Factor</a>. It is inspired by <a href="http://paste.lisp.org">lisppaste</a>.
- </p>
- <p>It can be used for collaborative development over IRC. You can post code for review, and annotate other people's code. Syntax highlighting for over a hundred file types is supported.
- </p>
- <p>
- <% "webapps.pastebin" browse-webapp-source %></p>
- </div>
- </td>
- </tr>
-</table>
-
-<% "footer" render-template %>
+++ /dev/null
-<% USING: continuations namespaces io kernel math math.parser
-furnace webapps.pastebin calendar sequences ; %>
-
-<tr>
- <td>
- <a href="<% model get paste-link write %>">
- <% "summary" get write %>
- </a>
- </td>
- <td><% "author" get write %></td>
- <td><% "date" get timestamp>string write %></td>
-</tr>
+++ /dev/null
-USING: calendar furnace furnace.validator io.files kernel
-namespaces sequences http.server.responders html math.parser rss
-xml.writer xmode.code2html math calendar.format ;
-IN: webapps.pastebin
-
-TUPLE: pastebin pastes ;
-
-: <pastebin> ( -- pastebin )
- V{ } clone pastebin construct-boa ;
-
-<pastebin> pastebin set-global
-
-TUPLE: paste
-summary author channel mode contents date
-annotations n ;
-
-: <paste> ( summary author channel mode contents -- paste )
- f V{ } clone f paste construct-boa ;
-
-TUPLE: annotation summary author mode contents ;
-
-C: <annotation> annotation
-
-: get-paste ( n -- paste )
- pastebin get pastebin-pastes nth ;
-
-: show-paste ( n -- )
- serving-html
- get-paste
- [ "show-paste" render-component ] with-html-stream ;
-
-\ show-paste { { "n" v-number } } define-action
-
-: new-paste ( -- )
- serving-html
- [ "new-paste" render-template ] with-html-stream ;
-
-\ new-paste { } define-action
-
-: paste-list ( -- )
- serving-html
- [
- [ show-paste ] "show-paste-quot" set
- [ new-paste ] "new-paste-quot" set
- pastebin get "paste-list" render-component
- ] with-html-stream ;
-
-\ paste-list { } define-action
-
-: paste-link ( paste -- link )
- paste-n number>string [ show-paste ] curry quot-link ;
-
-: safe-head ( seq n -- seq' )
- over length min head ;
-
-: paste-feed ( -- entries )
- pastebin get pastebin-pastes <reversed> 20 safe-head [
- {
- paste-summary
- paste-link
- paste-date
- } get-slots timestamp>rfc3339 f swap <entry>
- ] map ;
-
-: feed.xml ( -- )
- "text/xml" serving-content
- "pastebin"
- "http://pastebin.factorcode.org"
- paste-feed <feed> feed>xml write-xml ;
-
-\ feed.xml { } define-action
-
-: add-paste ( paste pastebin -- )
- >r now over set-paste-date r>
- pastebin-pastes 2dup length swap set-paste-n push ;
-
-: submit-paste ( summary author channel mode contents -- )
- <paste> [ pastebin get add-paste ] keep
- paste-link permanent-redirect ;
-
-\ new-paste
-\ submit-paste {
- { "summary" v-required }
- { "author" v-required }
- { "channel" }
- { "mode" v-required }
- { "contents" v-required }
-} define-form
-
-\ new-paste {
- { "channel" "#concatenative" }
- { "mode" "factor" }
-} default-values
-
-: annotate-paste ( n summary author mode contents -- )
- <annotation> swap get-paste
- [ paste-annotations push ] keep
- paste-link permanent-redirect ;
-
-[ "n" show-paste ]
-\ annotate-paste {
- { "n" v-required v-number }
- { "summary" v-required }
- { "author" v-required }
- { "mode" v-required }
- { "contents" v-required }
-} define-form
-
-\ show-paste {
- { "mode" "factor" }
-} default-values
-
-: style.css ( -- )
- "text/css" serving-content
- "style.css" send-resource ;
-
-\ style.css { } define-action
-
-"pastebin" "paste-list" "extra/webapps/pastebin" web-app
+++ /dev/null
-<% USING: namespaces io furnace sequences xmode.code2html calendar ; %>
-
-<%
- "Paste: " "summary" get append "title" set
- "header" render-template
-%>
-
-<table>
-<tr><th>Paste by:</th><td><% "author" get write %></td></tr>
-<!-- <tr><th>Channel:</th><td><% "channel" get write %></td></tr> -->
-<tr><th>Created:</th><td><% "date" get timestamp>string write %></td></tr>
-<tr><th>File type:</th><td><% "mode" get write %></td></tr>
-</table>
-
-<% "syntax" render-template %>
-
-<% "annotations" get [ "annotation" render-component ] each %>
-
-<% model get "annotate-paste" render-component %>
-
-<% "footer" render-template %>
+++ /dev/null
-body {
- font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#888;
-}
-
-h1.pastebin-title {
- font-size:300%;
-}
-
-a {
- color:#222;
- border-bottom:1px dotted #ccc;
- text-decoration:none;
-}
-
-a:hover {
- border-bottom:1px solid #ccc;
-}
-
-pre.code {
- border:1px dashed #ccc;
- background-color:#f5f5f5;
- padding:5px;
- font-size:150%;
- color:#000000;
-}
-
-.navbar {
- background-color:#eeeeee;
- padding:5px;
- border:1px solid #ccc;
-}
-
-.infobox {
- border: 1px solid #C1DAD7;
- padding: 10px;
-}
-
-.error {
- color: red;
-}
+++ /dev/null
-<% USING: xmode.code2html splitting namespaces ; %>
-
-<pre class="code"><% "contents" get string-lines "mode" get htmlize-lines %></pre>
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: sequences rss arrays concurrency.combinators kernel
-sorting html.elements io assocs namespaces math threads vocabs
-html furnace http.server.templating calendar math.parser
-splitting continuations debugger system http.server.responders
-xml.writer prettyprint logging calendar.format ;
-IN: webapps.planet
-
-: print-posting-summary ( posting -- )
- <p "news" =class p>
- <b> dup entry-title write </b> <br/>
- <a entry-link =href "more" =class a>
- "Read More..." write
- </a>
- </p> ;
-
-: print-posting-summaries ( postings -- )
- [ print-posting-summary ] each ;
-
-: print-blogroll ( blogroll -- )
- <ul "description" =class ul>
- [
- <li> <a dup third =href a> first write </a> </li>
- ] each
- </ul> ;
-
-: format-date ( date -- string )
- rfc3339>timestamp timestamp>string ;
-
-: print-posting ( posting -- )
- <h2 "posting-title" =class h2>
- <a dup entry-link =href a>
- dup entry-title write-html
- </a>
- </h2>
- <p "posting-body" =class p>
- dup entry-description write-html
- </p>
- <p "posting-date" =class p>
- entry-pub-date format-date write
- </p> ;
-
-: print-postings ( postings -- )
- [ print-posting ] each ;
-
-SYMBOL: default-blogroll
-SYMBOL: cached-postings
-
-: safe-head ( seq n -- seq' )
- over length min head ;
-
-: mini-planet-factor ( -- )
- cached-postings get 4 safe-head print-posting-summaries ;
-
-: planet-factor ( -- )
- serving-html [ "planet" render-template ] with-html-stream ;
-
-\ planet-factor { } define-action
-
-: planet-feed ( -- feed )
- "[ planet-factor ]"
- "http://planet.factorcode.org"
- cached-postings get 30 safe-head <feed> ;
-
-: feed.xml ( -- )
- "text/xml" serving-content
- planet-feed feed>xml write-xml ;
-
-\ feed.xml { } define-action
-
-: style.css ( -- )
- "text/css" serving-content
- "style.css" send-resource ;
-
-\ style.css { } define-action
-
-SYMBOL: last-update
-
-: <posting> ( author entry -- entry' )
- clone
- [ ": " swap entry-title 3append ] keep
- [ set-entry-title ] keep ;
-
-: fetch-feed ( url -- feed )
- download-feed feed-entries ;
-
-\ fetch-feed DEBUG add-error-logging
-
-: fetch-blogroll ( blogroll -- entries )
- dup 0 <column> swap 1 <column>
- [ fetch-feed ] parallel-map
- [ [ <posting> ] with map ] 2map concat ;
-
-: sort-entries ( entries -- entries' )
- [ [ entry-pub-date ] compare ] sort <reversed> ;
-
-: update-cached-postings ( -- )
- default-blogroll get
- fetch-blogroll sort-entries
- cached-postings set-global ;
-
-: update-thread ( -- )
- millis last-update set-global
- [ update-cached-postings ] "RSS feed update slave" spawn drop
- 10 60 * 1000 * sleep
- update-thread ;
-
-: start-update-thread ( -- )
- [
- "webapps.planet" [
- update-thread
- ] with-logging
- ] "RSS feed update master" spawn drop ;
-
-"planet" "planet-factor" "extra/webapps/planet" web-app
-
-{
- { "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" }
- { "Chris Double" "http://www.blogger.com/feeds/18561009/posts/full/-/factor" "http://www.bluishcoder.co.nz/" }
- { "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
- { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
- { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
- { "Gavin Harrison" "http://gmh33.blogspot.com/feeds/posts/default" "http://gmh33.blogspot.com/" }
- { "Kio M. Smallwood"
- "http://sekenre.wordpress.com/feed/atom/"
- "http://sekenre.wordpress.com/" }
- { "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
- { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
- { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
-} default-blogroll set-global
+++ /dev/null
-<% USING: namespaces html.elements webapps.planet sequences
-furnace ; %>
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
-<html xmlns="http://www.w3.org/1999/xhtml">
-<head>
- <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
-
- <title>planet-factor</title>
- <link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
- <link rel="alternate" type="application/atom+xml" title="Planet Factor - Atom" href="feed.xml" />
-</head>
-
-<body id="index">
- <h1 class="planet-title">[ planet-factor ]</h1>
- <table width="100%" cellpadding="10">
- <tr>
- <td> <% cached-postings get 20 safe-head print-postings %> </td>
- <td valign="top" width="25%" class="infobox">
- <p>
- <b>planet-factor</b> is an Atom/RSS aggregator that collects the
- contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It is inspired by
- <a href="http://planet.lisp.org">Planet Lisp</a>.
- </p>
- <p>
- <img src="http://planet.lisp.org/feed-icon-14x14.png" />
- <a href="feed.xml"> Syndicate </a>
- </p>
- <p>
- This webapp is written in <a href="http://factorcode.org/">Factor</a>.<br/>
- <% "webapps.planet" browse-webapp-source %>
- </p>
- <h2 class="blogroll-title">Blogroll</h2>
- <% default-blogroll get print-blogroll %>
- <p>
- If you want your weblog added to the blogroll, <a href="http://factorcode.org/gethelp.fhtml">just ask</a>.
- </p>
- </td>
- </tr>
- </table>
-</body>
-
-</html>
+++ /dev/null
-body {
- font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#888;
-}
-
-h1.planet-title {
- font-size:300%;
-}
-
-a {
- color:#222;
- border-bottom:1px dotted #ccc;
- text-decoration:none;
-}
-
-a:hover {
- border-bottom:1px solid #ccc;
-}
-
-.posting-title {
- background-color:#f5f5f5;
-}
-
-pre, code {
- color:#000000;
- font-size:120%;
-}
-
-.infobox {
- border-left: 1px solid #C1DAD7;
-}
-
-.posting-date {
- text-align: right;
- font-size:90%;
-}
-
-a.more {
- display:block;
- padding:0 0 5px 0;
- color:#333;
- text-decoration:none;
- text-align:right;
- border:none;
-}
+++ /dev/null
-REQUIRES: apps/http-server libs/store ;
-
-PROVIDE: apps/wee-url
-{ +files+ { "responder.factor" } } ;
+++ /dev/null
-! Copyright (C) 2006 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: generic assocs help html httpd
-io kernel math namespaces prettyprint sequences store strings ;
-IN: wee-url-responder
-
-SYMBOL: wee-shortcuts
-SYMBOL: wee-store
-
-"wee-url.store" load-store wee-store set-global
-H{ } clone wee-shortcuts wee-store get store-variable
-
-: responder-url "responder-url" get ;
-
-: wee-url ( string -- url )
- [
- "http://" %
- host %
- responder-url %
- %
- ] "" make ;
-
-: letter-bank
- "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" ;
-
-: random-letter letter-bank length random letter-bank nth ;
-
-: random-url ( -- string )
- 6 random 1+ [ drop random-letter ] map >string
- dup wee-shortcuts get key? [ drop random-url ] when ;
-
-: prepare-wee-url ( url -- url )
- CHAR: : over member? [ "http://" swap append ] unless ;
-
-: set-symmetric-hash ( obj1 obj2 hash -- )
- 3dup set-at swapd set-at ;
-
-: add-shortcut ( url-long -- url-short )
- dup wee-shortcuts get at* [
- nip
- ] [
- drop
- random-url [ wee-shortcuts get set-symmetric-hash ] keep
- wee-store get save-store
- ] if ;
-
-: url-prompt ( -- )
- serving-html
- "wee-url.com - wee URLs since 2007" [
- <form "get" =method responder-url =action form>
- "URL: " write
- <input "text" =type "url" =name input/>
- <input "submit" =type "Submit" =value input/>
- </form>
- ] simple-html-document ;
-
-: url-submitted ( url-long url-short -- )
- "URL Submitted" [
- "URL: " write write nl
- "wee-url: " write
- <a dup wee-url =href a> wee-url write </a> nl
- "Back to " write
- <a responder-url =href a> "wee-url" write </a> nl
- ] simple-html-document ;
-
-: url-submit ( url -- )
- serving-html
- prepare-wee-url [ add-shortcut ] keep url-submitted ;
-
-: url-error ( -- )
- serving-html
- "wee-url error" [
- "No such link." write
- ] simple-html-document ;
-
-: wee-url-responder ( url -- )
- "url" query-param [
- url-submit drop
- ] [
- dup empty? [
- drop url-prompt
- ] [
- wee-shortcuts get at*
- [ permanent-redirect ] [ drop url-error ] if
- ] if
- ] if* ;
-
-[
- "wee-url" "responder" set
- [ wee-url-responder ] "get" set
-] make-responder
+++ /dev/null
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs furnace html html.elements http.server
-http.server.responders io kernel math math.ranges
-namespaces random sequences store strings ;
-IN: webapps.wee-url
-
-SYMBOL: shortcuts
-SYMBOL: store
-
-! "wee-url.store" load-store store set-global
-! H{ } clone shortcuts store get store-variable
-
-: set-at-once ( value key assoc -- ? )
- 2dup key? [ 3drop f ] [ set-at t ] if ;
-
-: responder-url "responder/wee-url" ;
-
-: wee-url ( string -- url )
- [
- "http://" %
- host %
- responder-url %
- %
- ] "" make ;
-
-: letter-bank
- "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" ; inline
-
-: random-url ( -- string )
- 1 6 [a,b] random [ drop letter-bank random ] "" map-as
- dup shortcuts get key? [ drop random-url ] when ;
-
-: add-shortcut ( url-long url-short -- url-short )
- shortcuts get set-at-once [
- store get save-store
- ] [
- drop
- ] if ;
-
-: show-submit ( -- )
- serving-html
- "wee-url.com - wee URLs since 2007" [
- <form "get" =method "url-submit" =action form>
- "URL: " write
- <input "text" =type "url" =name input/>
- <input "submit" =type "Submit" =value input/>
- </form>
- ] simple-html-document ;
-
-\ show-submit { } define-action
-
-: url-submitted ( url-long url-short -- )
- "URL Submitted" [
- "URL: " write write nl
- "wee-url: " write
- <a dup wee-url =href a> wee-url write </a> nl
- "Back to " write
- <a responder-url =href a> "wee-url" write </a> nl
- ] simple-html-document ;
-
-: url-submit ( url -- )
- [ add-shortcut ] keep
- url-submitted ;
-
-\ url-submit {
- { "url" }
-} define-action
-
-: url-error ( -- )
- serving-html
- "wee-url error" [
- "No such link." write
- ] simple-html-document ;
-
-: wee-url-responder ( url -- )
- "url" query-param [
- url-submit drop
- ] [
- dup empty? [
- drop show-submit
- ] [
- shortcuts get at*
- [ permanent-redirect ] [ drop url-error ] if
- ] if
- ] if* ;
-
-! "wee-url" "wee-url-responder" "extra/webapps/wee-url" web-app
-~
UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
+ write_barrier((CELL)new_string);
new_string->aux = tag_object(new_aux);
F_BYTE_ARRAY *aux = untag_object(string->aux);
}
REGISTER_UNTAGGED(string);
+ REGISTER_UNTAGGED(new_string);
fill_string(new_string,to_copy,capacity,fill);
+ UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
return new_string;
projects / factor.git / commitdiff