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) \
{ $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-
{ $values { "timestamp" timestamp } { "duration" duration } }
{ $description "Calculates a " { $snippet "duration" } " that represents the elapsed time since midnight of the input " { $snippet "timestamp" } "." } ;
+HELP: since-1970
+{ $values
+ { "duration" duration }
+ { "timestamp" timestamp } }
+{ $description "Adds the duration to the beginning of Unix time and returns the result as a timestamp." } ;
+
ARTICLE: "calendar" "Calendar"
"The two data types used throughout the calendar library:"
{ $subsection timestamp }
{ $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
-combinators.short-circuit ;
+locals classes.tuple math.order summary combinators.short-circuit ;
IN: calendar
HOOK: gmt-offset os ( -- hours minutes seconds )
: 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- ;
+: since-1970 ( duration -- timestamp )
+ unix-1970 time+ >local-time ;
+
M: timestamp sleep-until timestamp>millis sleep-until ;
M: duration sleep hence sleep-until ;
-USING: alien alien.c-types arrays calendar kernel structs
-math unix.time namespaces system ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.syntax arrays calendar
+kernel math unix unix.time namespaces system ;
IN: calendar.unix
+: timeval>unix-time ( timeval -- timestamp )
+ [ timeval-sec seconds ] [ timeval-usec microseconds ] bi
+ time+ since-1970 ;
+
+: timespec>unix-time ( timeval -- timestamp )
+ [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi
+ time+ since-1970 ;
+
: get-time ( -- alien )
f time <uint> localtime ;
{ $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> ;
: frame-required ( n -- ) \ frame-required boa , ;
-: stack-frame-size ( code -- n )
+: compute-stack-frame-size ( code -- n )
no-stack-frame [
dup frame-required? [ n>> max ] [ drop ] if
] reduce ;
: if-stack-frame ( frame-size quot -- )
swap dup no-stack-frame =
- [ 2drop ] [ stack-frame swap call ] if ; inline
+ [ 2drop ] [ stack-frame-size swap call ] if ; inline
M: word fixup*
{
: fixup ( code -- literals relocation labels code )
[
init-fixup
- dup stack-frame-size swap [ fixup* ] each drop
+ dup compute-stack-frame-size swap [ fixup* ] each drop
literal-table get >array
relocation-table get >byte-array
: return-size ( ctype -- n )
#! Amount of space we reserve for a return value.
- dup large-struct? [ heap-size ] [ drop 0 ] if ;
+ dup large-struct? [ heap-size ] [ drop 2 cells ] if ;
: alien-stack-frame ( params -- n )
- alien-parameters parameter-sizes drop ;
-
-: alien-invoke-frame ( params -- n )
- #! Two cells for temporary storage, temp@ and on x86.64,
- #! small struct return value unpacking
- [ return>> return-size ] [ alien-stack-frame ] bi
- + 2 cells + ;
-
-: set-stack-frame ( n -- )
- dup [ frame-required ] when* \ stack-frame set ;
-
-: with-stack-frame ( n quot -- )
- swap set-stack-frame
+ stack-frame new
+ swap
+ [ return>> return-size >>return ]
+ [ alien-parameters parameter-sizes drop >>params ] bi
+ dup [ params>> ] [ return>> ] bi + >>size
+ dup size>> stack-frame-size >>total-size ;
+
+: with-stack-frame ( params quot -- )
+ swap alien-stack-frame [ size>> frame-required ] [ stack-frame set ] bi
call
- f set-stack-frame ; inline
+ stack-frame off ; inline
GENERIC: reg-size ( register-class -- n )
#! parameters. If the C function is returning a structure,
#! the first parameter is an implicit target area pointer,
#! so we need to use a different offset.
- return>> dup large-struct?
- [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+ return>> large-struct?
+ [ %prepare-box-struct cell ] [ 0 ] if ;
: objects>registers ( params -- )
#! Generate code for unboxing a list of C types, then
M: #alien-invoke generate-node
params>>
- dup alien-invoke-frame [
+ dup [
end-basic-block
%prepare-alien-invoke
dup objects>registers
! #alien-indirect
M: #alien-indirect generate-node
params>>
- dup alien-invoke-frame [
+ dup [
! Flush registers
end-basic-block
! Save registers for GC
: callback-unwind ( params -- n )
{
- { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+ { [ dup abi>> "stdcall" = ] [ drop stack-frame get params>> ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
[ drop 0 ]
} cond ;
dup xt>> dup [
init-templates
%prologue-later
- dup alien-stack-frame [
+ dup [
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ %callback-return ]
[ 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>
--- /dev/null
+Slava Pestov
--- /dev/null
+CoreFoundation run loop integration
--- /dev/null
+Slava Pestov
--- /dev/null
+Vocabulary with init hook for running CoreFoundation event loop
--- /dev/null
+unportable
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic kernel kernel.private math memory
-namespaces make sequences layouts system hashtables classes
-alien byte-arrays combinators words sets ;
+USING: accessors arrays generic kernel kernel.private math
+memory namespaces make sequences layouts system hashtables
+classes alien byte-arrays combinators words sets ;
IN: cpu.architecture
! Register classes
HOOK: load-indirect cpu ( obj reg -- )
-HOOK: stack-frame cpu ( frame-size -- n )
+HOOK: stack-frame-size cpu ( frame-size -- n )
-: stack-frame* ( -- n )
- \ stack-frame get stack-frame ;
+TUPLE: stack-frame total-size size params return ;
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
HOOK: %box-long-long cpu ( n func -- )
-HOOK: %prepare-box-struct cpu ( size -- )
+HOOK: %prepare-box-struct cpu ( -- )
HOOK: %box-small-struct cpu ( c-type -- )
: xt-save ( n -- i ) 2 cells - ;
-M: ppc stack-frame ( n -- i )
+M: ppc stack-frame-size ( n -- i )
local@ factor-area-size + 4 cells align ;
M: temp-reg v>operand drop 11 ;
1 1 rot ADDI
0 MTLR ;
-: (%call) ( -- ) 11 MTLR BLRL ;
+: (%call) ( reg -- ) MTLR BLRL ;
-: (%jump) ( -- ) 11 MTCTR BCTR ;
+: (%jump) ( reg -- ) MTCTR BCTR ;
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
"offset" operand "n" operand 1 SRAWI
11 11 "offset" operand ADD
11 dup 6 cells LWZ
- (%jump)
+ 11 (%jump)
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
M: stack-params %load-param-reg ( stack reg reg-class -- )
drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
+: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
+
M: stack-params %save-param-reg ( stack reg reg-class -- )
#! Funky. Read the parameter from the caller's stack frame.
#! This word is used in callbacks
drop
- 0 1 rot param@ stack-frame* + LWZ
+ 0 1 rot next-param@ LWZ
0 1 rot local@ STW ;
M: ppc %prepare-unbox ( -- )
M: ppc %unbox-large-struct ( n c-type -- )
! Value must be in r3
- ! Compute destination address
- 4 1 roll local@ ADDI
- ! Load struct size
- heap-size 5 LI
+ ! Compute destination address and load struct size
+ [ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi*
! Call the function
"to_value_struct" f %alien-invoke ;
4 1 rot cell + local@ LWZ
] when* r> f %alien-invoke ;
-: temp@ ( m -- n ) stack-frame* factor-area-size - swap - ;
-
-: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
+: struct-return@ ( n -- n )
+ [ stack-frame get params>> ] unless* local@ ;
-M: ppc %prepare-box-struct ( size -- )
+M: ppc %prepare-box-struct ( -- )
#! Compute target address for value struct return
- 3 1 rot f struct-return@ ADDI
+ 3 1 f struct-return@ ADDI
3 1 0 local@ STW ;
M: ppc %box-large-struct ( n c-type -- )
- #! If n = f, then we're boxing a returned struct
- heap-size
- [ swap struct-return@ ] keep
- ! Compute destination address
- 3 1 roll ADDI
- ! Load struct size
- 4 LI
+ ! If n = f, then we're boxing a returned struct
+ ! Compute destination address and load struct size
+ [ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi*
! Call the function
"box_value_struct" f %alien-invoke ;
rs-reg 11 12 STW ;
M: ppc %alien-invoke ( symbol dll -- )
- 11 %load-dlsym (%call) ;
+ 11 %load-dlsym 11 (%call) ;
M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ;
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
- 3 1 cell temp@ STW ;
+ 13 3 MR ;
M: ppc %alien-indirect ( -- )
- 11 1 cell temp@ LWZ (%call) ;
+ 13 (%call) ;
M: ppc %callback-value ( ctype -- )
! Save top of data stack
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types arrays cpu.x86.assembler
+USING: locals alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences
-stack-checker.known-words
-compiler.generator.registers compiler.generator.fixup
-compiler.generator system layouts combinators
-command-line compiler compiler.units io vocabs.loader accessors
-init ;
+stack-checker.known-words compiler.generator.registers
+compiler.generator.fixup compiler.generator system layouts
+combinators command-line compiler compiler.units io
+vocabs.loader accessors init ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
-M: x86.32 stack-save-reg EDX ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
heap-size { 1 2 4 8 } member?
os { linux netbsd solaris } member? not and ;
+: struct-return@ ( n -- operand )
+ [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
+
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
M: int-regs vregs drop { EAX ECX EDX EBP } ;
M: int-regs push-return-reg return-reg PUSH ;
-: load/store-int-return ( n reg-class -- src dst )
- return-reg stack-reg rot [+] ;
-M: int-regs load-return-reg load/store-int-return MOV ;
-M: int-regs store-return-reg load/store-int-return swap MOV ;
+
+M: int-regs load-return-reg
+ return-reg swap next-stack@ MOV ;
+
+M: int-regs store-return-reg
+ [ stack@ ] [ return-reg ] bi* MOV ;
M: float-regs param-regs drop { } ;
M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
M: float-regs push-return-reg
- stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
+ stack-reg swap reg-size
+ [ SUB ] [ [ [] ] dip FSTP ] 2bi ;
: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
-: load/store-float-return ( n reg-class -- op size )
- [ stack@ ] [ reg-size ] bi* ;
-M: float-regs load-return-reg load/store-float-return FLD ;
-M: float-regs store-return-reg load/store-float-return FSTP ;
+M: float-regs load-return-reg
+ [ next-stack@ ] [ reg-size ] bi* FLD ;
+
+M: float-regs store-return-reg
+ [ stack@ ] [ reg-size ] bi* FSTP ;
: align-sub ( n -- )
- dup 16 align swap - ESP swap SUB ;
+ [ align-stack ] keep - decr-stack-reg ;
: align-add ( n -- )
- 16 align ESP swap ADD ;
+ align-stack incr-stack-reg ;
: with-aligned-stack ( n quot -- )
- swap dup align-sub slip align-add ; inline
+ [ [ align-sub ] [ call ] bi* ]
+ [ [ align-add ] [ drop ] bi* ] 2bi ; inline
M: x86.32 fixnum>slot@ 1 SHR ;
M: object %save-param-reg 3drop ;
-: box@ ( n reg-class -- stack@ )
- #! Used for callbacks; we want to box the values given to
- #! us by the C function caller. Computes stack location of
- #! nth parameter; note that we must go back one more stack
- #! frame, since %box sets one up to call the one-arg boxer
- #! function. The size of this stack frame so far depends on
- #! the reg-class of the boxer's arg.
- reg-size neg + stack-frame* + 20 + ;
-
: (%box) ( n reg-class -- )
#! If n is f, push the return register onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n] on the stack; we are boxing a
#! parameter being passed to a callback from C.
- over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
- push-return-reg ;
+ over [ load-return-reg ] [ 2drop ] if ;
-M: x86.32 %box ( n reg-class func -- )
- over reg-size [
- >r (%box) r> f %alien-invoke
+M:: x86.32 %box ( n reg-class func -- )
+ n reg-class (%box)
+ reg-class reg-size [
+ reg-class push-return-reg
+ func f %alien-invoke
] with-aligned-stack ;
: (%box-long-long) ( n -- )
- #! If n is f, push the return registers onto the stack; we
- #! are boxing a return value of a C function. If n is an
- #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
- #! boxing a parameter being passed to a callback from C.
[
- int-regs box@
- EDX over stack@ MOV
- EAX swap cell - stack@ MOV
- ] when*
- EDX PUSH
- EAX PUSH ;
+ EDX over next-stack@ MOV
+ EAX swap cell - next-stack@ MOV
+ ] when* ;
M: x86.32 %box-long-long ( n func -- )
+ [ (%box-long-long) ] dip
8 [
- [ (%box-long-long) ] [ f %alien-invoke ] bi*
+ EDX PUSH
+ EAX PUSH
+ f %alien-invoke
] with-aligned-stack ;
-: struct-return@ ( size n -- n )
- [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
-
-M: x86.32 %box-large-struct ( n c-type -- )
+M:: x86.32 %box-large-struct ( n c-type -- )
! Compute destination address
- heap-size
- [ swap struct-return@ ] keep
- ECX ESP roll [+] LEA
+ ECX n struct-return@ LEA
8 [
! Push struct size
- PUSH
+ c-type heap-size PUSH
! Push destination address
ECX PUSH
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke
] with-aligned-stack ;
-M: x86.32 %prepare-box-struct ( size -- )
+M: x86.32 %prepare-box-struct ( -- )
! Compute target address for value struct return
- EAX ESP rot f struct-return@ [+] LEA
+ EAX f struct-return@ LEA
! Store it as the first parameter
- ESP [] EAX MOV ;
+ 0 stack@ EAX MOV ;
M: x86.32 %box-small-struct ( c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
} case ;
M: x86.32 %unbox-large-struct ( n c-type -- )
- #! Alien must be in EAX.
- heap-size
+ ! Alien must be in EAX.
! Compute destination address
- ECX ESP roll [+] LEA
+ ECX rot stack@ LEA
12 [
! Push struct size
- PUSH
+ heap-size PUSH
! Push destination address
ECX PUSH
! Push source address
M: x86.32 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
- cell temp@ EAX MOV ;
+ EBP EAX MOV ;
M: x86.32 %alien-indirect ( -- )
- cell temp@ CALL ;
+ EBP CALL ;
M: x86.32 %alien-callback ( quot -- )
4 [
M: x86.32 %callback-value ( ctype -- )
! Align C stack
ESP 12 SUB
- ! Save top of data stack
+ ! Save top of data stack in non-volatile register
%prepare-unbox
EAX PUSH
! Restore data/call/retain stacks
{
{
[ dup abi>> "stdcall" = ]
- [ alien-stack-frame ESP swap SUB ]
+ [ drop ESP stack-frame get params>> SUB ]
} {
[ dup return>> large-struct? ]
[ drop EAX PUSH ]
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
-M: x86.64 stack-save-reg RSI ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
r> stack@ R11 MOV ;
M: stack-params %save-param-reg
- >r stack-frame* + cell + swap r> %load-param-reg ;
+ drop
+ R11 swap next-stack@ MOV
+ stack@ R11 MOV ;
: with-return-regs ( quot -- )
[
! Source is in RDI
heap-size
! Load destination address
- RSI RSP roll [+] LEA
+ RSI rot stack@ LEA
! Load structure size
RDX swap MOV
! Copy the struct to the C stack
M: x86.64 struct-small-enough? ( size -- ? )
heap-size 2 cells <= ;
-: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
+: box-struct-field@ ( i -- operand ) 1+ cells stack@ ;
: %box-struct-field ( c-type i -- )
box-struct-field@ swap reg-class>> {
"box_small_struct" f %alien-invoke
] with-return-regs ;
-: struct-return@ ( size n -- n )
- [ ] [ \ stack-frame get swap - ] ?if ;
+: struct-return@ ( n -- operand )
+ [ stack-frame get params>> ] unless* stack@ ;
M: x86.64 %box-large-struct ( n c-type -- )
! Struct size is parameter 2
- heap-size
- RSI over MOV
+ RSI swap heap-size MOV
! Compute destination address
- swap struct-return@ RDI RSP rot [+] LEA
+ RDI swap struct-return@ LEA
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke ;
-M: x86.64 %prepare-box-struct ( size -- )
+M: x86.64 %prepare-box-struct ( -- )
! Compute target address for value struct return
- RAX RSP rot f struct-return@ [+] LEA
- RSP 0 [+] RAX MOV ;
+ RAX f struct-return@ LEA
+ ! Store it as the first parameter
+ 0 stack@ RAX MOV ;
M: x86.64 %prepare-var-args RAX RAX XOR ;
M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
- cell temp@ RAX MOV ;
+ RBP RAX MOV ;
M: x86.64 %alien-indirect ( -- )
- cell temp@ CALL ;
+ RBP CALL ;
M: x86.64 %alien-callback ( quot -- )
RDI load-indirect "c_to_factor" f %alien-invoke ;
M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
%prepare-unbox
- ! Put former top of data stack in RDI
- cell temp@ RDI MOV
+ ! Save top of data stack
+ RSP 8 SUB
+ RDI PUSH
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Put former top of data stack in RDI
- RDI cell temp@ MOV
+ RDI POP
+ RSP 8 ADD
! Unbox former top of data stack to return registers
unbox-return ;
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
HOOK: stack-reg cpu ( -- reg )
-HOOK: stack-save-reg cpu ( -- reg )
: stack@ ( n -- op ) stack-reg swap [+] ;
+: next-stack@ ( n -- operand )
+ #! nth parameter from the next stack frame. Used to box
+ #! input values to callbacks; the callback has its own
+ #! stack frame set up, and we want to read the frame
+ #! set up by the caller.
+ stack-frame get total-size>> + stack@ ;
+
: reg-stack ( n reg -- op ) swap cells neg [+] ;
M: ds-loc v>operand n>> ds-reg reg-stack ;
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
GENERIC: push-return-reg ( reg-class -- )
-GENERIC: load-return-reg ( stack@ reg-class -- )
-GENERIC: store-return-reg ( stack@ reg-class -- )
+GENERIC: load-return-reg ( n reg-class -- )
+GENERIC: store-return-reg ( n reg-class -- )
! Only used by inline allocation
HOOK: temp-reg-1 cpu ( -- reg )
M: immediate load-literal v>operand swap v>operand MOV ;
-M: x86 stack-frame ( n -- i )
- 3 cells + 16 align cell - ;
+: align-stack ( n -- n' )
+ os macosx? cpu x86.64? or [ 16 align ] when ;
+
+M: x86 stack-frame-size ( n -- i )
+ 3 cells + align-stack ;
M: x86 %save-word-xt ( -- )
temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
-: factor-area-size ( -- n ) 4 cells ;
+: decr-stack-reg ( n -- )
+ dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
M: x86 %prologue ( n -- )
- dup cell + PUSH
+ dup PUSH
temp-reg v>operand PUSH
- stack-reg swap 2 cells - SUB ;
+ 3 cells - decr-stack-reg ;
-M: x86 %epilogue ( n -- )
- stack-reg swap ADD ;
+: incr-stack-reg ( n -- )
+ dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
+
+M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
HOOK: %alien-global cpu ( symbol dll register -- )
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
-: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
-
M: x86 %return ( -- ) 0 %unwind ;
! Alien intrinsics
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 } }
{ $description "Disposes an associative list of statements." } ;
-HELP: db-dispose
-{ $values { "db" db } }
-{ $description "Disposes of all the statements stored in the " { $link db } " object." } ;
-
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 } }
-{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. The database called is based on the " { $snippet "class" } " with the " } ;
+ { "db" db } { "quot" quotation } }
+{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. See " { $link "db-custom-database-combinators" } " for help setting up database access." } ;
HELP: with-transaction
{ $values
{ $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 ; inline"> }
+
+"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 ; inline">
+} ;
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 -- )
: dispose-statements ( assoc -- ) values dispose-each ;
-: db-dispose ( db -- )
+M: db dispose ( db -- )
dup db [
- {
- [ insert-statements>> dispose-statements ]
- [ update-statements>> dispose-statements ]
- [ delete-statements>> dispose-statements ]
- [ handle>> db-close ]
- } cleave
+ [ dispose-statements H{ } clone ] change-insert-statements
+ [ dispose-statements H{ } clone ] change-update-statements
+ [ dispose-statements H{ } clone ] change-delete-statements
+ [ db-close f ] change-handle
+ drop
] with-variable ;
TUPLE: result-set sql in-params out-params handle n max ;
: 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 -- )
- handle>> PQfinish ;
+M: postgresql-db db-close ( handle -- )
+ PQfinish ;
M: postgresql-statement bind-statement* ( statement -- ) drop ;
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% ]
where-clause
] query-make ;
+ERROR: all-slots-ignored class ;
+
M: db <select-by-slots-statement> ( tuple class -- statement )
[
"select " 0%
[ dupd filter-ignores ] dip
+ over empty? [ all-slots-ignored ] when
over
[ ", " 0% ]
[ dup column-name>> 0% 2, ] interleave
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
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 ;
M: sqlite-db db-close ( handle -- ) sqlite-close ;
-M: sqlite-db dispose ( db -- ) db-dispose ;
TUPLE: sqlite-statement < statement ;
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 -- )
[
in-params>> [ sqlite-bind-conversion ] with map
] keep bind-statement ;
+ERROR: sqlite-last-id-fail ;
+
: last-insert-id ( -- id )
db get handle>> sqlite3_last_insert_rowid
- dup zero? [ "last-id failed" throw ] when ;
+ dup zero? [ sqlite-last-id-fail ] when ;
M: sqlite-db insert-tuple-set-key ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
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 ;
<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% ;
! 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 ;
[ f ]
[ T{ exam { name IGNORE } { score IGNORE } } select-tuples first score>> ] unit-test
- ! FIXME
- ! [ f ]
- ! [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] unit-test
+ [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] [ class>> "EXAM" = ] must-fail-with
[
{
[ 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 } ;
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
\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
! 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" }
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" }
] if ; inline recursive
: read-unchunked ( quot: ( chunk -- ) -- )
- 8192 read dup [
+ 8192 read-partial dup [
[ swap call ] [ drop read-unchunked ] 2bi
] [ 2drop ] if ; inline recursive
: 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 ;
html.streams ;
IN: http.server
+\ parse-cookie DEBUG add-input-logging
+
: check-absolute ( url -- url )
dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
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>
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types generic assocs kernel kernel.private
-math io.ports sequences strings structs sbufs threads unix
+math io.ports sequences strings sbufs threads unix
vectors io.buffers io.backend io.encodings math.parser
continuations system libc qualified namespaces make io.timeouts
io.encodings.utf8 destructors accessors summary combinators
-locals ;
+locals unix.time ;
QUALIFIED: io
IN: io.unix.backend
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.ports io.unix.backend
bit-arrays sequences assocs unix unix.linux.epoll math
-namespaces structs ;
+namespaces unix.time ;
IN: io.unix.epoll
TUPLE: epoll-mx < mx events ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel alien.syntax math io.unix.files system
+unix.stat accessors combinators calendar.unix ;
+IN: io.unix.files.bsd
+
+TUPLE: bsd-file-info < unix-file-info birth-time flags gen ;
+
+M: bsd new-file-info ( -- class ) bsd-file-info new ;
+
+M: bsd stat>file-info ( stat -- file-info )
+ [ call-next-method ] keep
+ {
+ [ stat-st_flags >>flags ]
+ [ stat-st_gen >>gen ]
+ [ stat-st_birthtimespec timespec>unix-time >>birth-time ]
+ } cleave ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes help.markup help.syntax io.streams.string
+strings math calendar io.files ;
+IN: io.unix.files
+
+HELP: file-group-id
+{ $values
+ { "path" "a pathname string" }
+ { "gid" integer } }
+{ $description "Returns the group id for a given file." } ;
+
+HELP: file-group-name
+{ $values
+ { "path" "a pathname string" }
+ { "string" string } }
+{ $description "Returns the group name for a given file." } ;
+
+HELP: file-permissions
+{ $values
+ { "path" "a pathname string" }
+ { "n" integer } }
+{ $description "Returns the Unix file permissions for a given file." } ;
+
+HELP: file-username
+{ $values
+ { "path" "a pathname string" }
+ { "string" string } }
+{ $description "Returns the username for a given file." } ;
+
+HELP: file-user-id
+{ $values
+ { "path" "a pathname string" }
+ { "uid" integer } }
+{ $description "Returns the user id for a given file." } ;
+
+HELP: group-execute?
+{ $values
+ { "path" "a pathname string" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file." } ;
+
+HELP: group-read?
+{ $values
+ { "path" "a pathname string" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "group read" } " bit is set on a file." } ;
+
+HELP: group-write?
+{ $values
+ { "path" "a pathname string" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "group write" } " bit is set on a file." } ;
+
+HELP: other-execute?
+{ $values
+ { "path" "a pathname string" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "other execute" } " bit is set on a file." } ;
+
+HELP: other-read?
+{ $values
+ { "path" "a pathname string" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "other read" } " bit is set on a file." } ;
+
+HELP: other-write?
+{ $values
+ { "path" "a pathname string" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "other write" } " bit is set on a file." } ;
+
+HELP: set-file-access-time
+{ $values
+ { "path" "a pathname string" } { "timestamp" timestamp } }
+{ $description "Sets a file's last access timestamp." } ;
+
+HELP: set-file-group
+{ $values
+ { "path" "a pathname string" } { "string/id" "a string or a group id" } }
+{ $description "Sets a file's group id from the given group id or group name." } ;
+
+HELP: set-file-ids
+{ $values
+ { "path" "a pathname string" } { "uid" integer } { "gid" integer } }
+{ $description "Sets the user id and group id of a file with a single library call." } ;
+
+HELP: set-file-permissions
+{ $values
+ { "path" "a pathname string" } { "n" "an integer, interepreted as a string of bits" } }
+{ $description "Sets the file permissions for a given file with the supplied Unix permissions integer. Supplying an octal number with " { $link POSTPONE: OCT: } " is recommended." }
+{ $examples "Using the tradidional octal value:"
+ { $unchecked-example "USING: io.unix.files kernel ;"
+ "\"resource:license.txt\" OCT: 755 set-file-permissions"
+ ""
+ }
+ "Higher-level, setting named bits:"
+ { $unchecked-example "USING: io.unix.files kernel math.bitwise ;"
+ "\"resource:license.txt\""
+ "{ USER-ALL GROUP-READ GROUP-EXECUTE OTHER-READ OTHER-EXECUTE }"
+ "flags set-file-permissions"
+ "" }
+} ;
+
+HELP: set-file-times
+{ $values
+ { "path" "a pathname string" } { "timestamps" "an array of two timestamps" } }
+{ $description "Sets the access and write timestamps for a file as provided in the input array. A value of " { $link f } " provided for either of the timestamps will not change that timestamp." } ;
+
+HELP: set-file-user
+{ $values
+ { "path" "a pathname string" } { "string/id" "a string or a user id" } }
+{ $description "Sets a file's user id from the given user id or username." } ;
+
+HELP: set-file-modified-time
+{ $values
+ { "path" "a pathname string" } { "timestamp" timestamp } }
+{ $description "Sets a file's last modified timestamp, or write timestamp." } ;
+
+HELP: set-gid
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "gid" } " bit of a file to true or false." } ;
+
+HELP: gid?
+{ $values
+ { "path" "a pathname string" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file." } ;
+
+HELP: set-group-execute
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "group execute" } " bit of a file to true or false." } ;
+
+HELP: set-group-read
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "group read" } " bit of a file to true or false." } ;
+
+HELP: set-group-write
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "group write" } " bit of a file to true or false." } ;
+
+HELP: set-other-execute
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ;
+
+HELP: set-other-read
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "other read" } " bit of a file to true or false." } ;
+
+HELP: set-other-write
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ;
+
+HELP: set-sticky
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "sticky" } " bit of a file to true or false." } ;
+
+HELP: sticky?
+{ $values
+ { "path" "a pathname string" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "sticky" } " bit of a file is set." } ;
+
+HELP: set-uid
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "uid" } " bit of a file to true or false." } ;
+
+HELP: uid?
+{ $values
+ { "path" "a pathname string" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "uid" } " bit of a file is set." } ;
+
+HELP: set-user-execute
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "user execute" } " bit of a file to true or false." } ;
+
+HELP: set-user-read
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "user read" } " bit of a file to true or false." } ;
+
+HELP: set-user-write
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "user write" } " bit of a file to true or false." } ;
+
+HELP: user-execute?
+{ $values
+ { "path" "a pathname string" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "user execute" } " bit is set on a file." } ;
+
+HELP: user-read?
+{ $values
+ { "path" "a pathname string" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "user read" } " bit is set on a file." } ;
+
+HELP: user-write?
+{ $values
+ { "path" "a pathname string" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "user write" } " bit is set on a file." } ;
+
+ARTICLE: "unix-file-permissions" "Unix file permissions"
+"Reading all file permissions:"
+{ $subsection file-permissions }
+"Reading individual file permissions:"
+{ $subsection uid? }
+{ $subsection gid? }
+{ $subsection sticky? }
+{ $subsection user-read? }
+{ $subsection user-write? }
+{ $subsection user-execute? }
+{ $subsection group-read? }
+{ $subsection group-write? }
+{ $subsection group-execute? }
+{ $subsection other-read? }
+{ $subsection other-write? }
+{ $subsection other-execute? }
+"Writing all file permissions:"
+{ $subsection set-file-permissions }
+"Writing individual file permissions:"
+{ $subsection set-uid }
+{ $subsection set-gid }
+{ $subsection set-sticky }
+{ $subsection set-user-read }
+{ $subsection set-user-write }
+{ $subsection set-user-execute }
+{ $subsection set-group-read }
+{ $subsection set-group-write }
+{ $subsection set-group-execute }
+{ $subsection set-other-read }
+{ $subsection set-other-write }
+{ $subsection set-other-execute } ;
+
+ARTICLE: "unix-file-timestamps" "Unix file timestamps"
+"To read file times, use the accessors on the object returned by the " { $link file-info } " word." $nl
+"Setting multiple file times:"
+{ $subsection set-file-times }
+"Setting just the last access time:"
+{ $subsection set-file-access-time }
+"Setting just the last modified time:"
+{ $subsection set-file-modified-time } ;
+
+
+ARTICLE: "unix-file-ids" "Unix file user and group ids"
+"Reading file user data:"
+{ $subsection file-user-id }
+{ $subsection file-username }
+"Setting file user data:"
+{ $subsection set-file-user }
+"Reading file group data:"
+{ $subsection file-group-id }
+{ $subsection file-group-name }
+"Setting file group data:"
+{ $subsection set-file-group } ;
+
+
+ARTICLE: "io.unix.files" "Unix file attributes"
+"The " { $vocab-link "io.unix.files" } " vocabulary implements the Unix backend for opening files and provides a high-level way to set permissions, timestamps, and user and group ids for files."
+{ $subsection "unix-file-permissions" }
+{ $subsection "unix-file-timestamps" }
+{ $subsection "unix-file-ids" } ;
+
+ABOUT: "io.unix.files"
-USING: tools.test io.files ;
+USING: tools.test io.files continuations kernel io.unix.files
+math.bitwise calendar accessors math.functions math unix.users
+unix.groups arrays sequences ;
IN: io.unix.files.tests
[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test
[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
[ t ] [ "/foo" absolute-path? ] unit-test
+
+: test-file ( -- path )
+ "permissions" temp-file ;
+
+: prepare-test-file ( -- )
+ [ test-file delete-file ] ignore-errors
+ test-file touch-file ;
+
+: perms ( -- n )
+ test-file file-permissions OCT: 7777 mask ;
+
+prepare-test-file
+
+[ t ]
+[ test-file { USER-ALL GROUP-ALL OTHER-ALL } flags set-file-permissions perms OCT: 777 = ] unit-test
+
+[ t ] [ test-file user-read? ] unit-test
+[ t ] [ test-file user-write? ] unit-test
+[ t ] [ test-file user-execute? ] unit-test
+[ t ] [ test-file group-read? ] unit-test
+[ t ] [ test-file group-write? ] unit-test
+[ t ] [ test-file group-execute? ] unit-test
+[ t ] [ test-file other-read? ] unit-test
+[ t ] [ test-file other-write? ] unit-test
+[ t ] [ test-file other-execute? ] unit-test
+
+[ t ]
+[ test-file f set-other-execute perms OCT: 776 = ] unit-test
+
+[ t ]
+[ test-file f set-other-write perms OCT: 774 = ] unit-test
+
+[ t ]
+[ test-file f set-other-read perms OCT: 770 = ] unit-test
+
+[ t ]
+[ test-file f set-group-execute perms OCT: 760 = ] unit-test
+
+[ t ]
+[ test-file f set-group-write perms OCT: 740 = ] unit-test
+
+[ t ]
+[ test-file f set-group-read perms OCT: 700 = ] unit-test
+
+[ t ]
+[ test-file f set-user-execute perms OCT: 600 = ] unit-test
+
+[ t ]
+[ test-file f set-user-write perms OCT: 400 = ] unit-test
+
+[ t ]
+[ test-file f set-user-read perms OCT: 000 = ] unit-test
+
+[ t ]
+[ test-file { USER-ALL GROUP-ALL OTHER-EXECUTE } flags set-file-permissions perms OCT: 771 = ] unit-test
+
+prepare-test-file
+
+[ t ]
+[
+ test-file now
+ [ set-file-access-time ] 2keep
+ [ file-info accessed>> ]
+ [ [ [ truncate >integer ] change-second ] bi@ ] bi* =
+] unit-test
+
+[ t ]
+[
+ test-file now
+ [ set-file-modified-time ] 2keep
+ [ file-info modified>> ]
+ [ [ [ truncate >integer ] change-second ] bi@ ] bi* =
+] unit-test
+
+[ t ]
+[
+ test-file now [ dup 2array set-file-times ] 2keep
+ [ file-info [ modified>> ] [ accessed>> ] bi ] dip
+ 3array
+ [ [ truncate >integer ] change-second ] map all-equal?
+] unit-test
+
+[ ] [ test-file f now 2array set-file-times ] unit-test
+[ ] [ test-file now f 2array set-file-times ] unit-test
+[ ] [ test-file f f 2array set-file-times ] unit-test
+
+
+[ ] [ test-file real-username set-file-user ] unit-test
+[ ] [ test-file real-user-id set-file-user ] unit-test
+[ ] [ test-file real-group-name set-file-group ] unit-test
+[ ] [ test-file real-group-id set-file-group ] unit-test
+
+[ t ] [ test-file file-username real-username = ] unit-test
+[ t ] [ test-file file-group-name real-group-name = ] unit-test
+
+[ ]
+[ test-file real-user-id real-group-id set-file-ids ] unit-test
+
+[ ]
+[ test-file f real-group-id set-file-ids ] unit-test
+
+[ ]
+[ test-file real-user-id f set-file-ids ] unit-test
+
+[ ]
+[ test-file f f set-file-ids ] unit-test
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.ports io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations
math.bitwise byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system
-io.files.private destructors ;
-
+io.files.private destructors vocabs.loader calendar.unix
+unix.stat alien.c-types arrays unix.users unix.groups ;
IN: io.unix.files
M: unix cwd ( -- path )
[ swap file-info permissions>> chmod io-error ]
2bi ;
-: stat>type ( stat -- type )
+HOOK: stat>file-info os ( stat -- file-info )
+
+HOOK: stat>type os ( stat -- file-info )
+
+HOOK: new-file-info os ( -- class )
+
+TUPLE: unix-file-info < file-info uid gid dev ino
+nlink rdev blocks blocksize ;
+
+M: unix file-info ( path -- info )
+ normalize-path file-status stat>file-info ;
+
+M: unix link-info ( path -- info )
+ normalize-path link-status stat>file-info ;
+
+M: unix make-link ( path1 path2 -- )
+ normalize-path symlink io-error ;
+
+M: unix read-link ( path -- path' )
+ normalize-path read-symbolic-link ;
+
+M: unix new-file-info ( -- class ) unix-file-info new ;
+
+M: unix stat>file-info ( stat -- file-info )
+ [ new-file-info ] dip
+ {
+ [ stat>type >>type ]
+ [ stat-st_size >>size ]
+ [ stat-st_mode >>permissions ]
+ [ stat-st_ctimespec timespec>unix-time >>created ]
+ [ stat-st_mtimespec timespec>unix-time >>modified ]
+ [ stat-st_atimespec timespec>unix-time >>accessed ]
+ [ stat-st_uid >>uid ]
+ [ stat-st_gid >>gid ]
+ [ stat-st_dev >>dev ]
+ [ stat-st_ino >>ino ]
+ [ stat-st_nlink >>nlink ]
+ [ stat-st_rdev >>rdev ]
+ [ stat-st_blocks >>blocks ]
+ [ stat-st_blksize >>blocksize ]
+ } cleave ;
+
+M: unix stat>type ( stat -- type )
stat-st_mode S_IFMT bitand {
{ S_IFREG [ +regular-file+ ] }
{ S_IFDIR [ +directory+ ] }
[ drop +unknown+ ]
} case ;
-: stat>file-info ( stat -- info )
- {
- [ stat>type ]
- [ stat-st_size ]
- [ stat-st_mode ]
- [ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
- } cleave
- \ file-info boa ;
+! Linux has no extra fields in its stat struct
+os {
+ { macosx [ "io.unix.files.bsd" require ] }
+ { netbsd [ "io.unix.files.bsd" require ] }
+ { openbsd [ "io.unix.files.bsd" require ] }
+ { freebsd [ "io.unix.files.bsd" require ] }
+ { linux [ ] }
+} case
-M: unix file-info ( path -- info )
- normalize-path file-status stat>file-info ;
+<PRIVATE
-M: unix link-info ( path -- info )
- normalize-path link-status stat>file-info ;
+: stat-mode ( path -- mode )
+ normalize-path file-status stat-st_mode ;
+
+: chmod-set-bit ( path mask ? -- )
+ [ dup stat-mode ] 2dip
+ [ bitor ] [ unmask ] if chmod io-error ;
-M: unix make-link ( path1 path2 -- )
- normalize-path symlink io-error ;
+: file-mode? ( path mask -- ? ) [ stat-mode ] dip mask? ;
-M: unix read-link ( path -- path' )
- normalize-path read-symbolic-link ;
\ No newline at end of file
+PRIVATE>
+
+: UID OCT: 0004000 ; inline
+: GID OCT: 0002000 ; inline
+: STICKY OCT: 0001000 ; inline
+: USER-ALL OCT: 0000700 ; inline
+: USER-READ OCT: 0000400 ; inline
+: USER-WRITE OCT: 0000200 ; inline
+: USER-EXECUTE OCT: 0000100 ; inline
+: GROUP-ALL OCT: 0000070 ; inline
+: GROUP-READ OCT: 0000040 ; inline
+: GROUP-WRITE OCT: 0000020 ; inline
+: GROUP-EXECUTE OCT: 0000010 ; inline
+: OTHER-ALL OCT: 0000007 ; inline
+: OTHER-READ OCT: 0000004 ; inline
+: OTHER-WRITE OCT: 0000002 ; inline
+: OTHER-EXECUTE OCT: 0000001 ; inline
+
+: uid? ( path -- ? ) UID file-mode? ;
+: gid? ( path -- ? ) GID file-mode? ;
+: sticky? ( path -- ? ) STICKY file-mode? ;
+: user-read? ( path -- ? ) USER-READ file-mode? ;
+: user-write? ( path -- ? ) USER-WRITE file-mode? ;
+: user-execute? ( path -- ? ) USER-EXECUTE file-mode? ;
+: group-read? ( path -- ? ) GROUP-READ file-mode? ;
+: group-write? ( path -- ? ) GROUP-WRITE file-mode? ;
+: group-execute? ( path -- ? ) GROUP-EXECUTE file-mode? ;
+: other-read? ( path -- ? ) OTHER-READ file-mode? ;
+: other-write? ( path -- ? ) OTHER-WRITE file-mode? ;
+: other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ;
+
+: set-uid ( path ? -- ) UID swap chmod-set-bit ;
+: set-gid ( path ? -- ) GID swap chmod-set-bit ;
+: set-sticky ( path ? -- ) STICKY swap chmod-set-bit ;
+: set-user-read ( path ? -- ) USER-READ swap chmod-set-bit ;
+: set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ;
+: set-user-execute ( path ? -- ) USER-EXECUTE swap chmod-set-bit ;
+: set-group-read ( path ? -- ) GROUP-READ swap chmod-set-bit ;
+: set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ;
+: set-group-execute ( path ? -- ) GROUP-EXECUTE swap chmod-set-bit ;
+: set-other-read ( path ? -- ) OTHER-READ swap chmod-set-bit ;
+: set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ;
+: set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
+
+: set-file-permissions ( path n -- )
+ [ normalize-path ] dip chmod io-error ;
+
+: file-permissions ( path -- n )
+ normalize-path file-info permissions>> ;
+
+<PRIVATE
+
+: make-timeval-array ( array -- byte-array )
+ [ length "timeval" <c-array> ] keep
+ dup length [ over [ pick set-timeval-nth ] [ 2drop ] if ] 2each ;
+
+: timestamp>timeval ( timestamp -- timeval )
+ unix-1970 time- duration>milliseconds make-timeval ;
+
+: timestamps>byte-array ( timestamps -- byte-array )
+ [ dup [ timestamp>timeval ] when ] map make-timeval-array ;
+
+PRIVATE>
+
+: set-file-times ( path timestamps -- )
+ #! set access, write
+ [ normalize-path ] dip
+ timestamps>byte-array utimes io-error ;
+
+: set-file-access-time ( path timestamp -- )
+ f 2array set-file-times ;
+
+: set-file-modified-time ( path timestamp -- )
+ f swap 2array set-file-times ;
+
+: set-file-ids ( path uid gid -- )
+ [ normalize-path ] 2dip
+ [ [ -1 ] unless* ] bi@ chown io-error ;
+
+GENERIC: set-file-user ( path string/id -- )
+
+GENERIC: set-file-group ( path string/id -- )
+
+M: integer set-file-user ( path uid -- )
+ f set-file-ids ;
+
+M: string set-file-user ( path string -- )
+ user-id f set-file-ids ;
+
+M: integer set-file-group ( path gid -- )
+ f swap set-file-ids ;
+
+M: string set-file-group ( path string -- )
+ group-id
+ f swap set-file-ids ;
+
+: file-user-id ( path -- uid )
+ normalize-path file-info uid>> ;
+
+: file-username ( path -- string )
+ file-user-id username ;
+
+: file-group-id ( path -- gid )
+ normalize-path file-info gid>> ;
+
+: file-group-name ( path -- string )
+ file-group-id group-name ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.ports io.unix.backend math.bitwise
unix io.files.unique.backend system ;
IN: io.unix.files.unique
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.ports io.unix.backend
-bit-arrays sequences assocs unix math namespaces structs
-accessors math.order locals ;
+bit-arrays sequences assocs unix math namespaces
+accessors math.order locals unix.time ;
IN: io.unix.select
TUPLE: select-mx < mx read-fdset write-fdset ;
! 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)
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
+ [ \ file-info new ] dip
{
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
+ [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
[
[ WIN32_FIND_DATA-nFileSizeLow ]
- [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit
+ [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
]
- [ WIN32_FIND_DATA-dwFileAttributes ]
- ! [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp ]
- [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ]
- ! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ]
- } cleave
- \ file-info boa ;
+ [ WIN32_FIND_DATA-dwFileAttributes >>permissions ]
+ [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ]
+ [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ]
+ [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ]
+ } cleave ;
: find-first-file-stat ( path -- WIN32_FIND_DATA )
"WIN32_FIND_DATA" <c-object> [
] keep ;
: BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
+ [ \ file-info new ] dip
{
- [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type ]
+ [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ]
[
[ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
- [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit
+ [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size
+ ]
+ [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ]
+ [
+ BY_HANDLE_FILE_INFORMATION-ftCreationTime
+ FILETIME>timestamp >>created
+ ]
+ [
+ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime
+ FILETIME>timestamp >>modified
+ ]
+ [
+ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime
+ FILETIME>timestamp >>accessed
]
- [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ]
- ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ]
- [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
- ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
! [
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
! ]
- } cleave
- \ file-info boa ;
+ } cleave ;
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
[
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
"lambda" word-prop body>> ;
M: lambda-macro reset-word
- [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+ [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
INTERSECTION: lambda-method method-body lambda-word ;
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"
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 { "seq" sequence } { "elt" "a random element" } }
+{ $description "Outputs a random element of the input sequence. Outputs " { $link f } " if the sequence is empty." }
+{ $notes "Since integers are sequences, passing an integer " { $snippet "n" } " outputs an integer in the interval " { $snippet "[0,n)" } "." }
+{ $examples
+ { $unchecked-example "USING: random prettyprint ;"
+ "10 random ."
+ "3" }
+ { $unchecked-example "USING: random prettyprint ;"
+ "SYMBOL: heads"
+ "SYMBOL: tails"
+ "{ heads tails } random ."
+ "heads" }
+} ;
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."
+$nl
+"The ``Mersenne Twister'' pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "."
+$nl
+"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
+
+[ f ] [ 0 random ] unit-test
random-generator get random-bytes*
] keep head ;
+<PRIVATE
+
+: random-integer ( n -- n' )
+ dup log2 7 + 8 /i 1+
+ [ random-bytes byte-array>bignum ]
+ [ 3 shift 2^ ] bi / * >integer ;
+
+PRIVATE>
+
+: random-bits ( n -- r ) 2^ random-integer ;
+
: 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 ;
-
-: random-bits ( n -- r ) 2^ random ;
+ [ length random-integer ] keep [ nth ] 2keep delete-nth ;
: with-random ( tuple quot -- )
random-generator swap with-variable ; inline
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: alien.c-types alien.syntax kernel math ;
-IN: structs
-
-C-STRUCT: timeval
- { "long" "sec" }
- { "long" "usec" } ;
-
-: make-timeval ( ms -- timeval )
- 1000 /mod 1000 *
- "timeval" <c-object>
- [ set-timeval-usec ] keep
- [ set-timeval-sec ] keep ;
+++ /dev/null
-Cross-platform C structs
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 = os windows? or [
+ [
+ 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
USING: tools.deploy.config ;
H{
- { deploy-threads? f }
- { deploy-ui? f }
+ { deploy-reflection 1 }
+ { deploy-word-props? f }
{ deploy-io 1 }
- { deploy-c-types? f }
{ deploy-name "tools.deploy.test.6" }
+ { deploy-math? t }
+ { deploy-random? f }
{ deploy-compiler? t }
- { deploy-reflection 1 }
- { deploy-word-props? f }
+ { deploy-ui? f }
+ { deploy-c-types? f }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
- { deploy-random? f }
- { deploy-math? f }
+ { deploy-threads? f }
}
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
+ ] [ drop ] if ;
: 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
! 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 ;
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
: make-RECT ( world -- RECT )
- dup window-loc>> { 40 40 } vmax dup rot rect-dim v+
+ dup window-loc>> dup rot rect-dim v+
"RECT" <c-object>
over first over set-RECT-right
swap second over set-RECT-bottom
over first over set-RECT-left
swap second over set-RECT-top ;
+: default-position-RECT ( RECT -- )
+ dup get-RECT-dimensions [ 2drop ] 2dip
+ CW_USEDEFAULT + pick set-RECT-bottom
+ CW_USEDEFAULT + over set-RECT-right
+ CW_USEDEFAULT over set-RECT-left
+ CW_USEDEFAULT swap set-RECT-top ;
+
: make-adjusted-RECT ( rect -- RECT )
- make-RECT dup adjust-RECT ;
+ make-RECT
+ dup get-RECT-top-left [ zero? ] both? swap
+ dup adjust-RECT
+ swap [ dup default-position-RECT ] when ;
: create-window ( rect -- hwnd )
make-adjusted-RECT
+! 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 ;
{ "uchar" "family" }
{ { "char" 104 } "path" } ;
+C-STRUCT: passwd
+ { "char*" "pw_name" }
+ { "char*" "pw_passwd" }
+ { "uid_t" "pw_uid" }
+ { "gid_t" "pw_gid" }
+ { "time_t" "pw_change" }
+ { "char*" "pw_class" }
+ { "char*" "pw_gecos" }
+ { "char*" "pw_dir" }
+ { "char*" "pw_shell" }
+ { "time_t" "pw_expire" }
+ { "int" "pw_fields" } ;
+
: max-un-path 104 ; inline
: SOCK_STREAM 1 ; inline
-USING: alien.syntax ;
+USING: alien.syntax unix.time ;
IN: unix
: FD_SETSIZE 1024 ; inline
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
-C-STRUCT: passwd
- { "char*" "pw_name" }
- { "char*" "pw_passwd" }
- { "uid_t" "pw_uid" }
- { "gid_t" "pw_gid" }
- { "time_t" "pw_change" }
- { "char*" "pw_class" }
- { "char*" "pw_gecos" }
- { "char*" "pw_dir" }
- { "char*" "pw_shell" }
- { "time_t" "pw_expire" }
- { "int" "pw_fields" } ;
-
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline
: ETIME 101 ; inline
: EOPNOTSUPP 102 ; inline
: ENOPOLICY 103 ; inline
+
+: _UTX_USERSIZE 256 ; inline
+: _UTX_LINESIZE 32 ; inline
+: _UTX_IDSIZE 4 ; inline
+: _UTX_HOSTSIZE 256 ; inline
+
+C-STRUCT: utmpx
+ { { "char" _UTX_USERSIZE } "ut_user" }
+ { { "char" _UTX_IDSIZE } "ut_id" }
+ { { "char" _UTX_LINESIZE } "ut_line" }
+ { "pid_t" "ut_pid" }
+ { "short" "ut_type" }
+ { "timeval" "ut_tv" }
+ { { "char" _UTX_HOSTSIZE } "ut_host" }
+ { { "uint" 16 } "ut_pad" } ;
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types math vocabs.loader ;
IN: unix
: FD_SETSIZE 256 ; inline
: ENOLINK 95 ; inline
: EPROTO 96 ; inline
: ELAST 96 ; inline
+
+TYPEDEF: __uint8_t sa_family_t
+
+: _UTX_USERSIZE 32 ; inline
+: _UTX_LINESIZE 32 ; inline
+: _UTX_IDSIZE 4 ; inline
+: _UTX_HOSTSIZE 256 ; inline
+
+: _SS_MAXSIZE ( -- n )
+ 128 ; inline
+
+: _SS_ALIGNSIZE ( -- n )
+ "__int64_t" heap-size ; inline
+
+: _SS_PAD1SIZE ( -- n )
+ _SS_ALIGNSIZE 2 - ; inline
+
+: _SS_PAD2SIZE ( -- n )
+ _SS_MAXSIZE 2 - _SS_PAD1SIZE - _SS_ALIGNSIZE - ; inline
+
+"unix.bsd.netbsd.structs" require
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax unix.time ;
+IN: unix
+
+C-STRUCT: sockaddr_storage
+ { "__uint8_t" "ss_len" }
+ { "sa_family_t" "ss_family" }
+ { { "char" _SS_PAD1SIZE } "__ss_pad1" }
+ { "__int64_t" "__ss_align" }
+ { { "char" _SS_PAD2SIZE } "__ss_pad2" } ;
+
+C-STRUCT: exit_struct
+ { "uint16_t" "e_termination" }
+ { "uint16_t" "e_exit" } ;
+
+C-STRUCT: utmpx
+ { { "char" _UTX_USERSIZE } "ut_user" }
+ { { "char" _UTX_IDSIZE } "ut_id" }
+ { { "char" _UTX_LINESIZE } "ut_line" }
+ { { "char" _UTX_HOSTSIZE } "ut_host" }
+ { "uint16_t" "ut_session" }
+ { "uint16_t" "ut_type" }
+ { "pid_t" "ut_pid" }
+ { "exit_struct" "ut_exit" }
+ { "sockaddr_storage" "ut_ss" }
+ { "timeval" "ut_tv" }
+ { { "uint32_t" 10 } "ut_pad" } ;
+
--- /dev/null
+unportable
--- /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 kernel quotations sequences strings math ;
+IN: unix.groups
+
+HELP: all-groups
+{ $values
+
+ { "seq" sequence } }
+{ $description "Returns a sequence of " { $link group } " tuples that are platform-dependent and field for field complete with the Unix " { $link group } " structure." } ;
+
+HELP: effective-group-id
+{ $values
+
+ { "string" string } }
+{ $description "Returns the effective group id for the current user." } ;
+
+HELP: effective-group-name
+{ $values
+
+ { "string" string } }
+{ $description "Returns the effective group name for the current user." } ;
+
+HELP: group
+{ $description "A platform-specific tuple corresponding to every field from the Unix group struct including the group name, the group id, the group passwd, and a list of users in each group." } ;
+
+HELP: group-cache
+{ $description "A symbol containing a cache of groups returned from " { $link all-groups } " and indexed by group id. Can be more efficient than using the system call words for many group lookups." } ;
+
+HELP: group-id
+{ $values
+ { "string" string }
+ { "id" integer } }
+{ $description "Returns the group id given a group name." } ;
+
+HELP: group-name
+{ $values
+ { "id" integer }
+ { "string" string } }
+{ $description "Returns the group name given a group id." } ;
+
+HELP: group-struct
+{ $values
+ { "obj" object }
+ { "group" "a group struct" } }
+{ $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
+
+HELP: real-group-id
+{ $values
+
+ { "id" integer } }
+{ $description "Returns the real group id for the current user." } ;
+
+HELP: real-group-name
+{ $values
+
+ { "string" string } }
+{ $description "Returns the real group name for the current user." } ;
+
+HELP: set-effective-group
+{ $values
+ { "obj" object } }
+{ $description "Sets the effective group id for the current user." } ;
+
+HELP: set-real-group
+{ $values
+ { "obj" object } }
+{ $description "Sets the real group id for the current user." } ;
+
+HELP: user-groups
+{ $values
+ { "string/id" "a string or a group id" }
+ { "seq" sequence } }
+{ $description "Returns the sequence of groups to which the user belongs." } ;
+
+HELP: with-effective-group
+{ $values
+ { "string/id" "a string or a group id" } { "quot" quotation } }
+{ $description "Sets the effective group name and calls the quotation. Restors the effective group name on success or on error after the call." } ;
+
+HELP: with-group-cache
+{ $values
+ { "quot" quotation } }
+{ $description "Iterates over the group file using library calls and creates a cache in the " { $link group-cache } " symbol. The cache is a hashtable indexed by group id. When looking up many groups, this approach is much faster than calling system calls." } ;
+
+HELP: with-real-group
+{ $values
+ { "string/id" "a string or a group id" } { "quot" quotation } }
+{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call." } ;
+
+ARTICLE: "unix.groups" "unix.groups"
+"The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups."
+"Listing all groups:"
+{ $subsection all-groups }
+"Returning a passwd tuple:"
+"Real groups:"
+{ $subsection real-group-name }
+{ $subsection real-group-id }
+{ $subsection set-real-group }
+"Effective groups:"
+{ $subsection effective-group-name }
+{ $subsection effective-group-id }
+{ $subsection set-effective-group }
+"Combinators to change groups:"
+{ $subsection with-real-group }
+{ $subsection with-effective-group } ;
+
+ABOUT: "unix.groups"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test unix.groups kernel strings math ;
+IN: unix.groups.tests
+
+
+[ ] [ all-groups drop ] unit-test
+
+\ all-groups must-infer
+
+[ t ] [ real-group-name string? ] unit-test
+[ t ] [ effective-group-name string? ] unit-test
+
+[ t ] [ real-group-id integer? ] unit-test
+[ t ] [ effective-group-id integer? ] unit-test
+
+[ ] [ real-group-id set-real-group ] unit-test
+[ ] [ effective-group-id set-effective-group ] unit-test
+
+[ ] [ real-group-name [ ] with-real-group ] unit-test
+[ ] [ real-group-id [ ] with-real-group ] unit-test
+
+[ ] [ effective-group-name [ ] with-effective-group ] unit-test
+[ ] [ effective-group-id [ ] with-effective-group ] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings io.encodings.utf8
+io.unix.backend kernel math sequences splitting unix strings
+combinators.short-circuit byte-arrays combinators qualified
+accessors math.parser fry assocs namespaces continuations
+unix.users ;
+IN: unix.groups
+
+QUALIFIED: grouping
+
+TUPLE: group id name passwd members ;
+
+SYMBOL: group-cache
+
+GENERIC: group-struct ( obj -- group )
+
+<PRIVATE
+
+: group-members ( group-struct -- seq )
+ group-gr_mem
+ [ dup { [ ] [ *void* ] } 1&& ]
+ [
+ dup *void* utf8 alien>string
+ [ alien-address "char**" heap-size + <alien> ] dip
+ ] [ ] produce nip ;
+
+: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
+ "group" <c-object> tuck 4096
+ [ <byte-array> ] keep f <void*> ;
+
+M: integer group-struct ( id -- group )
+ (group-struct) getgrgid_r io-error ;
+
+M: string group-struct ( string -- group )
+ (group-struct) getgrnam_r 0 = [ (io-error) ] unless ;
+
+: group-struct>group ( group-struct -- group )
+ [ \ group new ] dip
+ {
+ [ group-gr_name >>name ]
+ [ group-gr_passwd >>passwd ]
+ [ group-gr_gid >>id ]
+ [ group-members >>members ]
+ } cleave ;
+
+PRIVATE>
+
+: group-name ( id -- string )
+ dup group-cache get [
+ at
+ ] [
+ group-struct group-gr_name
+ ] if*
+ [ nip ] [ number>string ] if* ;
+
+: group-id ( string -- id )
+ group-struct group-gr_gid ;
+
+<PRIVATE
+
+: >groups ( byte-array n -- groups )
+ [ 4 grouping:group ] dip head-slice [ *uint group-name ] map ;
+
+: (user-groups) ( string -- seq )
+ #! first group is -1337, legacy unix code
+ -1337 NGROUPS_MAX [ 4 * <byte-array> ] keep
+ <int> [ getgrouplist io-error ] 2keep
+ [ 4 tail-slice ] [ *int 1- ] bi* >groups ;
+
+PRIVATE>
+
+GENERIC: user-groups ( string/id -- seq )
+
+M: string user-groups ( string -- seq )
+ (user-groups) ;
+
+M: integer user-groups ( id -- seq )
+ username (user-groups) ;
+
+: all-groups ( -- seq )
+ [ getgrent dup ] [ group-struct>group ] [ drop ] produce ;
+
+: with-group-cache ( quot -- )
+ all-groups [ [ id>> ] keep ] H{ } map>assoc
+ group-cache rot with-variable ; inline
+
+: real-group-id ( -- id )
+ getgid ; inline
+
+: real-group-name ( -- string )
+ real-group-id group-name ; inline
+
+: effective-group-id ( -- string )
+ getegid ; inline
+
+: effective-group-name ( -- string )
+ effective-group-id group-name ; inline
+
+GENERIC: set-real-group ( obj -- )
+
+GENERIC: set-effective-group ( obj -- )
+
+: with-real-group ( string/id quot -- )
+ '[ _ set-real-group @ ]
+ real-group-id '[ _ set-real-group ] [ ] cleanup ; inline
+
+: with-effective-group ( string/id quot -- )
+ '[ _ set-effective-group @ ]
+ effective-group-id '[ _ set-effective-group ] [ ] cleanup ; inline
+
+<PRIVATE
+
+: (set-real-group) ( id -- )
+ setgid io-error ; inline
+
+: (set-effective-group) ( id -- )
+ setegid io-error ; inline
+
+PRIVATE>
+
+M: string set-real-group ( string -- )
+ group-id (set-real-group) ;
+
+M: integer set-real-group ( id -- )
+ (set-real-group) ;
+
+M: integer set-effective-group ( id -- )
+ (set-effective-group) ;
+
+M: string set-effective-group ( string -- )
+ group-id (set-effective-group) ;
--- /dev/null
+unportable
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: unix
USING: alien.syntax ;
+IN: unix
! Linux.
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "__dev_t" "st_rdev" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "__uint32_t" "pad1" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
-FUNCTION: int lstat ( char* pathname, stat* buf ) ;
\ No newline at end of file
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "__dev_t" "st_rdev" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "off_t" "st_size" }
{ "blksize_t" "st_blksize" }
{ "blkcnt_t" "st_blocks" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "ulong" "unused4" }
{ "ulong" "unused5" } ;
FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
: stat ( pathname buf -- int ) 3 -rot __xstat ;
-: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
\ No newline at end of file
+: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
{ "off_t" "st_size" }
{ "blksize_t" "st_blksize" }
{ "blkcnt_t" "st_blocks" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "long" "__unused0" }
{ "long" "__unused1" }
{ "long" "__unused2" } ;
-
USING: kernel alien.syntax math ;
-
IN: unix.stat
! Mac OS X ppc
+! stat64 structure
C-STRUCT: stat
{ "dev_t" "st_dev" }
- { "ino_t" "st_ino" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
+ { "ino64_t" "st_ino" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
+ { "timespec" "st_birthtimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "__int64_t" "st_qspare0" }
{ "__int64_t" "st_qspare1" } ;
-FUNCTION: int stat ( char* pathname, stat* buf ) ;
-FUNCTION: int lstat ( char* pathname, stat* buf ) ;
+FUNCTION: int stat64 ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat64 ( char* pathname, stat* buf ) ;
-: stat-st_atim ( stat -- timespec ) stat-st_atimespec ;
-: stat-st_mtim ( stat -- timespec ) stat-st_mtimespec ;
-: stat-st_ctim ( stat -- timespec ) stat-st_ctimespec ;
+: stat ( path buf -- n ) stat64 ;
+: lstat ( path buf -- n ) lstat64 ;
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
- { "timespec" "st_birthtim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
+ { "timespec" "st_birthtimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "uint32_t" "st_flags" }
{ "uint32_t" "st_gen" }
{ "uint32_t" "st_spare0" }
- { "timespec" "st_birthtim" } ;
+ { "timespec" "st_birthtimespec" } ;
FUNCTION: int __stat13 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat13 ( char* pathname, stat* buf ) ;
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "int32_t" "st_lspare0" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "int64_t" "st_blocks" }
{ "u_int32_t" "st_blksize" }
{ "u_int32_t" "st_flags" }
{ "u_int32_t" "st_gen" }
{ "int32_t" "st_lspare1" }
- { "timespec" "st_birthtim" }
+ { "timespec" "st_birthtimespec" }
{ { "int64_t" 2 } "st_qspare" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
-
USING: kernel system combinators alien.syntax alien.c-types
- math io.unix.backend vocabs.loader unix ;
-
+math io.unix.backend vocabs.loader unix ;
IN: unix.stat
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! File Types
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: S_IFMT OCT: 170000 ; ! These bits determine file type.
: S_IFLNK OCT: 120000 ; inline ! Symbolic link.
: S_IFSOCK OCT: 140000 ; inline ! Socket.
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! File Access Permissions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Read, write, execute/search by owner
-: S_IRWXU OCT: 0000700 ; inline ! rwx mask owner
-: S_IRUSR OCT: 0000400 ; inline ! r owner
-: S_IWUSR OCT: 0000200 ; inline ! w owner
-: S_IXUSR OCT: 0000100 ; inline ! x owner
-! Read, write, execute/search by group
-: S_IRWXG OCT: 0000070 ; inline ! rwx mask group
-: S_IRGRP OCT: 0000040 ; inline ! r group
-: S_IWGRP OCT: 0000020 ; inline ! w group
-: S_IXGRP OCT: 0000010 ; inline ! x group
-! Read, write, execute/search by others
-: S_IRWXO OCT: 0000007 ; inline ! rwx mask other
-: S_IROTH OCT: 0000004 ; inline ! r other
-: S_IWOTH OCT: 0000002 ; inline ! w other
-: S_IXOTH OCT: 0000001 ; inline ! x other
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
FUNCTION: int chmod ( char* path, mode_t mode ) ;
-
FUNCTION: int fchmod ( int fd, mode_t mode ) ;
-
FUNCTION: int mkdir ( char* path, mode_t mode ) ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-<<
- os
- {
+<< os {
{ linux [ "unix.stat.linux" require ] }
{ macosx [ "unix.stat.macosx" require ] }
{ freebsd [ "unix.stat.freebsd" require ] }
{ netbsd [ "unix.stat.netbsd" require ] }
{ openbsd [ "unix.stat.openbsd" require ] }
- }
- case
->>
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+} case >>
: file-status ( pathname -- stat )
- "stat" <c-object> dup >r
- [ stat ] unix-system-call drop
- r> ;
+ "stat" <c-object> [
+ [ stat ] unix-system-call drop
+ ] keep ;
: link-status ( pathname -- stat )
- "stat" <c-object> dup >r
- [ lstat ] unix-system-call drop
- r> ;
+ "stat" <c-object> [
+ [ lstat ] unix-system-call drop
+ ] keep ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel alien.syntax alien.c-types math unix.types ;
+IN: unix.time
-USING: kernel alien.syntax alien.c-types math ;
+C-STRUCT: timeval
+ { "long" "sec" }
+ { "long" "usec" } ;
-IN: unix.time
+C-STRUCT: timespec
+ { "time_t" "sec" }
+ { "long" "nsec" } ;
+
+: make-timeval ( ms -- timeval )
+ 1000 /mod 1000 *
+ "timeval" <c-object>
+ [ set-timeval-usec ] keep
+ [ set-timeval-sec ] keep ;
-TYPEDEF: uint time_t
+: make-timespec ( ms -- timespec )
+ 1000 /mod 1000000 *
+ "timespec" <c-object>
+ [ set-timespec-nsec ] keep
+ [ set-timespec-sec ] keep ;
C-STRUCT: tm
{ "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?)
{ "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?)
{ "char*" "zone" } ;
-C-STRUCT: timespec
- { "time_t" "sec" }
- { "long" "nsec" } ;
-
-: make-timespec ( ms -- timespec )
- 1000 /mod 1000000 *
- "timespec" <c-object>
- [ set-timespec-nsec ] keep
- [ set-timespec-sec ] keep ;
-
FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: tm* localtime ( time_t* clock ) ;
FUNCTION: int gettimeofday ( timespec* TP, void* TZP ) ;
TYPEDEF: __uint32_t gid_t
TYPEDEF: __int64_t off_t
TYPEDEF: __int64_t blkcnt_t
+TYPEDEF: __int64_t ino64_t
TYPEDEF: __int32_t blksize_t
TYPEDEF: long ssize_t
TYPEDEF: __int32_t pid_t
IN: unix.types
TYPEDEF: void* caddr_t
+TYPEDEF: uint in_addr_t
+TYPEDEF: uint socklen_t
+
+TYPEDEF: char int8_t
+TYPEDEF: short int16_t
+TYPEDEF: int int32_t
+TYPEDEF: longlong int64_t
+
+TYPEDEF: uchar uint8_t
+TYPEDEF: ushort uint16_t
+TYPEDEF: uint uint32_t
+TYPEDEF: ulonglong uint64_t
+
+TYPEDEF: char __int8_t
+TYPEDEF: short __int16_t
+TYPEDEF: int __int32_t
+TYPEDEF: longlong __int64_t
+
+TYPEDEF: uchar __uint8_t
+TYPEDEF: ushort __uint16_t
+TYPEDEF: uint __uint32_t
+TYPEDEF: ulonglong __uint64_t
+
os {
{ linux [ "unix.types.linux" require ] }
! 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
+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
-TYPEDEF: uint socklen_t
-
: PROT_NONE 0 ; inline
: PROT_READ 1 ; inline
: PROT_WRITE 2 ; inline
FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ;
FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
FUNCTION: int chdir ( char* path ) ;
+FUNCTION: int chmod ( char* path, mode_t mode ) ;
+FUNCTION: int fchmod ( int fd, mode_t mode ) ;
FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
FUNCTION: int chroot ( char* path ) ;
: _exit ( status -- * )
#! We throw to give this a terminating stack effect.
"int" f "_exit" { "int" } alien-invoke "Exit failed" throw ;
+FUNCTION: void endpwent ( ) ;
FUNCTION: int fchdir ( int fd ) ;
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
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: passwd* getpwuid ( uid_t uid ) ;
+FUNCTION: passwd* getpwnam ( char* login ) ;
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
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators accessors kernel unix unix.users
+system ;
+IN: unix.users.bsd
+
+TUPLE: bsd-passwd < passwd change class expire fields ;
+
+M: bsd new-passwd ( -- bsd-passwd ) bsd-passwd new ;
+
+M: bsd passwd>new-passwd ( passwd -- bsd-passwd )
+ [ call-next-method ] keep
+ {
+ [ passwd-pw_change >>change ]
+ [ passwd-pw_class >>class ]
+ [ passwd-pw_shell >>shell ]
+ [ passwd-pw_expire >>expire ]
+ [ passwd-pw_fields >>fields ]
+ } cleave ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string kernel quotations sequences strings math ;
+IN: unix.users
+
+HELP: all-users
+{ $values
+
+ { "seq" sequence } }
+{ $description "Returns a sequence of high-level " { $link passwd } " tuples that are platform-dependent and field for field complete with the Unix " { $link passwd } " structure." } ;
+
+HELP: effective-username
+{ $values
+
+ { "string" string } }
+{ $description "Returns the effective username for the current user." } ;
+
+HELP: effective-user-id
+{ $values
+
+ { "id" integer } }
+{ $description "Returns the effective username id for the current user." } ;
+
+HELP: new-passwd
+{ $values
+
+ { "passwd" passwd } }
+{ $description "Creates a new passwd tuple dependent on the operating system." } ;
+
+HELP: passwd
+{ $description "A platform-specific tuple correspding to every field from the Unix passwd struct. BSD passwd structures have four extra slots: " { $slot "change" } ", " { $slot "class" } "," { $slot "expire" } ", " { $slot "fields" } "." } ;
+
+HELP: passwd-cache
+{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-passwd-cache } "." } ;
+
+HELP: passwd>new-passwd
+{ $values
+ { "passwd" "a passwd struct" }
+ { "new-passwd" "a passwd tuple" } }
+{ $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ;
+
+HELP: real-username
+{ $values
+
+ { "string" string } }
+{ $description "The real username of the current user." } ;
+
+HELP: real-user-id
+{ $values
+
+ { "id" integer } }
+{ $description "The real user id of the current user." } ;
+
+HELP: set-effective-user
+{ $values
+ { "string/id" "a string or a user id" } }
+{ $description "Sets the current effective user given a username or a user id." } ;
+
+HELP: set-real-user
+{ $values
+ { "string/id" "a string or a user id" } }
+{ $description "Sets the current real user given a username or a user id." } ;
+
+HELP: user-passwd
+{ $values
+ { "obj" object }
+ { "passwd" passwd } }
+{ $description "Returns the passwd tuple given a username string or user id." } ;
+
+HELP: username
+{ $values
+ { "id" integer }
+ { "string" string } }
+{ $description "Returns the username associated with the user id." } ;
+
+HELP: user-id
+{ $values
+ { "string" string }
+ { "id" integer } }
+{ $description "Returns the user id associated with the username." } ;
+
+HELP: with-effective-user
+{ $values
+ { "string/id" "a string or a uid" } { "quot" quotation } }
+{ $description "Sets the effective username and calls the quotation. Restores the current username on success or on error after the call." } ;
+
+HELP: with-passwd-cache
+{ $values
+ { "quot" quotation } }
+{ $description "Iterates over the password file using library calls and creates a cache in the " { $link passwd-cache } " symbol. The cache is a hashtable indexed by user id. When looking up many users, this approach is much faster than calling system calls." } ;
+
+HELP: with-real-user
+{ $values
+ { "string/id" "a string or a uid" } { "quot" quotation } }
+{ $description "Sets the real username and calls the quotation. Restores the current username on success or on error after the call." } ;
+
+{
+ real-username real-user-id set-real-user
+ effective-username effective-user-id
+ set-effective-user
+} related-words
+
+ARTICLE: "unix.users" "unix.users"
+"The " { $vocab-link "unix.users" } " vocabulary contains words that return information about Unix users."
+"Listing all users:"
+{ $subsection all-users }
+"Returning a passwd tuple:"
+"Real user:"
+{ $subsection real-username }
+{ $subsection real-user-id }
+{ $subsection set-real-user }
+"Effective user:"
+{ $subsection effective-username }
+{ $subsection effective-user-id }
+{ $subsection set-effective-user }
+"Combinators to change users:"
+{ $subsection with-real-user }
+{ $subsection with-effective-user } ;
+
+ABOUT: "unix.users"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test unix.users kernel strings math ;
+IN: unix.users.tests
+
+
+[ ] [ all-users drop ] unit-test
+
+\ all-users must-infer
+
+[ t ] [ real-username string? ] unit-test
+[ t ] [ effective-username string? ] unit-test
+
+[ t ] [ real-user-id integer? ] unit-test
+[ t ] [ effective-user-id integer? ] unit-test
+
+[ ] [ real-user-id set-real-user ] unit-test
+[ ] [ effective-user-id set-effective-user ] unit-test
+
+[ ] [ real-username [ ] with-real-user ] unit-test
+[ ] [ real-user-id [ ] with-real-user ] unit-test
+
+[ ] [ effective-username [ ] with-effective-user ] unit-test
+[ ] [ effective-user-id [ ] with-effective-user ] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings io.encodings.utf8
+io.unix.backend kernel math sequences splitting unix strings
+combinators.short-circuit grouping byte-arrays combinators
+accessors math.parser fry assocs namespaces continuations
+vocabs.loader system ;
+IN: unix.users
+
+TUPLE: passwd username password uid gid gecos dir shell ;
+
+HOOK: new-passwd os ( -- passwd )
+HOOK: passwd>new-passwd os ( passwd -- new-passwd )
+
+<PRIVATE
+
+M: unix new-passwd ( -- passwd )
+ passwd new ;
+
+M: unix passwd>new-passwd ( passwd -- seq )
+ [ new-passwd ] dip
+ {
+ [ passwd-pw_name >>username ]
+ [ passwd-pw_passwd >>password ]
+ [ passwd-pw_uid >>uid ]
+ [ passwd-pw_gid >>gid ]
+ [ passwd-pw_gecos >>gecos ]
+ [ passwd-pw_dir >>dir ]
+ [ passwd-pw_shell >>shell ]
+ } cleave ;
+
+: with-pwent ( quot -- )
+ [ endpwent ] [ ] cleanup ; inline
+
+PRIVATE>
+
+: all-users ( -- seq )
+ [
+ [ getpwent dup ] [ passwd>new-passwd ] [ drop ] produce
+ ] with-pwent ;
+
+SYMBOL: passwd-cache
+
+: with-passwd-cache ( quot -- )
+ all-users [ [ uid>> ] keep ] H{ } map>assoc
+ passwd-cache swap with-variable ; inline
+
+GENERIC: user-passwd ( obj -- passwd )
+
+M: integer user-passwd ( id -- passwd/f )
+ passwd-cache get
+ [ at ] [ getpwuid passwd>new-passwd ] if* ;
+
+M: string user-passwd ( string -- passwd/f )
+ getpwnam dup [ passwd>new-passwd ] when ;
+
+: username ( id -- string )
+ user-passwd username>> ;
+
+: user-id ( string -- id )
+ user-passwd uid>> ;
+
+: real-user-id ( -- id )
+ getuid ; inline
+
+: real-username ( -- string )
+ real-user-id username ; inline
+
+: effective-user-id ( -- id )
+ geteuid ; inline
+
+: effective-username ( -- string )
+ effective-user-id username ; inline
+
+GENERIC: set-real-user ( string/id -- )
+
+GENERIC: set-effective-user ( string/id -- )
+
+: with-real-user ( string/id quot -- )
+ '[ _ set-real-user @ ]
+ real-user-id '[ _ set-real-user ]
+ [ ] cleanup ; inline
+
+: with-effective-user ( string/id quot -- )
+ '[ _ set-effective-user @ ]
+ effective-user-id '[ _ set-effective-user ]
+ [ ] cleanup ; inline
+
+<PRIVATE
+
+: (set-real-user) ( id -- )
+ setuid io-error ; inline
+
+: (set-effective-user) ( id -- )
+ seteuid io-error ; inline
+
+PRIVATE>
+
+M: string set-real-user ( string -- )
+ user-id (set-real-user) ;
+
+M: integer set-real-user ( id -- )
+ (set-real-user) ;
+
+M: integer set-effective-user ( id -- )
+ (set-effective-user) ;
+
+M: string set-effective-user ( string -- )
+ user-id (set-effective-user) ;
+
+os {
+ { [ dup bsd? ] [ drop "unix.users.bsd" require ] }
+ { [ dup linux? ] [ drop ] }
+} cond
--- /dev/null
+Doug Coleman
--- /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: tools.test unix.utmpx.macosx ;
+IN: unix.utmpx.macosx.tests
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax unix.bsd.macosx ;
+IN: unix.utmpx.macosx
+
+! empty
--- /dev/null
+unportable
--- /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: tools.test unix.utmpx.netbsd ;
+IN: unix.utmpx.netbsd.tests
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax unix.utmpx unix.bsd.netbsd accessors
+unix.utmpx system kernel unix combinators ;
+IN: unix.utmpx.netbsd
+
+TUPLE: netbsd-utmpx-record < utmpx-record termination exit
+sockaddr ;
+
+M: netbsd new-utmpx-record ( -- utmpx-record )
+ netbsd-utmpx-record new ;
+
+M: netbsd utmpx>utmpx-record ( utmpx -- record )
+ [ new-utmpx-record ] keep
+ {
+ [
+ utmpx-ut_exit
+ [ exit_struct-e_termination >>termination ]
+ [ exit_struct-e_exit >>exit ] bi
+ ]
+ [ utmpx-ut_ss >>sockaddr ]
+ } cleave ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax combinators continuations
+io.encodings.string io.encodings.utf8 kernel sequences strings
+unix calendar system accessors unix.time calendar.unix
+vocabs.loader ;
+IN: unix.utmpx
+
+: EMPTY 0 ; inline
+: RUN_LVL 1 ; inline
+: BOOT_TIME 2 ; inline
+: OLD_TIME 3 ; inline
+: NEW_TIME 4 ; inline
+: INIT_PROCESS 5 ; inline
+: LOGIN_PROCESS 6 ; inline
+: USER_PROCESS 7 ; inline
+: DEAD_PROCESS 8 ; inline
+: ACCOUNTING 9 ; inline
+: SIGNATURE 10 ; inline
+: SHUTDOWN_TIME 11 ; inline
+
+FUNCTION: void setutxent ( ) ;
+FUNCTION: void endutxent ( ) ;
+FUNCTION: utmpx* getutxent ( ) ;
+FUNCTION: utmpx* getutxid ( utmpx* id ) ;
+FUNCTION: utmpx* getutxline ( utmpx* line ) ;
+FUNCTION: utmpx* pututxline ( utmpx* utx ) ;
+
+TUPLE: utmpx-record user id line pid type timestamp host ;
+
+HOOK: new-utmpx-record os ( -- utmpx-record )
+
+HOOK: utmpx>utmpx-record os ( utmpx -- utmpx-record )
+
+: memory>string ( alien n -- string )
+ memory>byte-array utf8 decode [ 0 = ] trim-right ;
+
+M: unix new-utmpx-record
+ utmpx-record new ;
+
+M: unix utmpx>utmpx-record ( utmpx -- utmpx-record )
+ [ new-utmpx-record ] dip
+ {
+ [ utmpx-ut_user _UTX_USERSIZE memory>string >>user ]
+ [ utmpx-ut_id _UTX_IDSIZE memory>string >>id ]
+ [ utmpx-ut_line _UTX_LINESIZE memory>string >>line ]
+ [ utmpx-ut_pid >>pid ]
+ [ utmpx-ut_type >>type ]
+ [ utmpx-ut_tv timeval>unix-time >>timestamp ]
+ [ utmpx-ut_host _UTX_HOSTSIZE memory>string >>host ]
+ } cleave ;
+
+: with-utmpx ( quot -- )
+ setutxent [ endutxent ] [ ] cleanup ; inline
+
+: all-utmpx ( -- seq )
+ [
+ [ getutxent dup ]
+ [ utmpx>utmpx-record ]
+ [ drop ] produce
+ ] with-utmpx ;
+
+os {
+ { macosx [ "unix.utmpx.macosx" require ] }
+ { netbsd [ "unix.utmpx.netbsd" require ] }
+} case
--- /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: 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)." }
! 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 urls.encoding ;
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 ;
! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
-
+! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
byte-arrays kernel math sequences windows.types windows.kernel32
-windows.errors structs windows math.bitwise alias ;
+windows.errors windows math.bitwise alias ;
IN: windows.winsock
USE: libc
{ "sockaddr*" "addr" }
{ "addrinfo*" "next" } ;
+C-STRUCT: timeval
+ { "long" "sec" }
+ { "long" "usec" } ;
+
: hostent-addr ( hostent -- addr ) hostent-addr-list *void* ; ! *uint ;
LIBRARY: winsock
: init-winsock ( -- )
HEX: 0202 <wsadata> WSAStartup winsock-return-check ;
-
[ T{ syntax-test } ] [ T{ syntax-test } ] unit-test
[ T{ syntax-test f { 2 3 } { 4 { 5 } } } ]
[ T{ syntax-test { bar { 2 3 } } { baz { 4 { 5 } } } } ] unit-test
+
+! Corner case
+TUPLE: parsing-corner-case x ;
+
+[ T{ parsing-corner-case f 3 } ] [
+ {
+ "USE: classes.tuple.parser.tests"
+ "T{ parsing-corner-case"
+ " f"
+ " 3"
+ "}"
+ } "\n" join eval
+] unit-test
: parse-tuple-literal ( -- tuple )
scan-word scan {
+ { f [ unexpected-eof ] }
{ "f" [ \ } parse-until boa>tuple ] }
{ "{" [ parse-slot-values assoc>tuple ] }
{ "}" [ new ] }
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 )
"." last-split1 nip ;
! File info
-TUPLE: file-info type size permissions modified ;
+TUPLE: file-info type size permissions created modified accessed ;
HOOK: file-info io-backend ( path -- info )
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 -- )
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
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
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 )
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 ;
+! 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 ;
USING: help.markup help.syntax quotations kernel irc.messages ;
IN: irc.client
-HELP: irc-client "IRC Client object"
-"blah" ;
+HELP: irc-client "IRC Client object" ;
-HELP: irc-server-listener "Listener for server messages unmanaged by other listeners"
-"blah" ;
+HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
-HELP: irc-channel-listener "Listener for irc channels"
-"blah" ;
+HELP: irc-channel-chat "Chat for irc channels" ;
-HELP: irc-nick-listener "Listener for irc users"
-"blah" ;
+HELP: irc-nick-chat "Chat for irc users" ;
-HELP: irc-profile "IRC Client profile object"
-"blah" ;
+HELP: irc-profile "IRC Client profile object" ;
HELP: connect-irc "Connecting to an irc server"
{ $values { "irc-client" "an irc client object" } }
{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ;
-HELP: add-listener "Listening to irc channels/users/etc"
-{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } }
-{ $description "Registers " { $snippet "irc-listener" } " with " { $snippet "irc-client" } " and starts listening." } ;
+HELP: attach-chat "Chatting with irc channels/users/etc"
+{ $values { "irc-chat" "an irc chat object" } { "irc-client" "an irc client object" } }
+{ $description "Registers " { $snippet "irc-chat" } " with " { $snippet "irc-client" } " and starts listening." } ;
-HELP: remove-listener "Stop an unregister listener"
-{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } }
-{ $description "Unregisters " { $snippet "irc-listener" } " from " { $snippet "irc-client" } " and stops listening. This is how you part from a channel." } ;
+HELP: detach-chat "Stop an unregister chat"
+{ $values { "irc-chat" "an irc chat object" } }
+{ $description "Unregisters " { $snippet "irc-chat" } " from " { $snippet "irc-client" } " and stops listening. This is how you part from a channel." } ;
HELP: terminate-irc "Terminates an irc client"
{ $values { "irc-client" "an irc client object" } }
-{ $description "Terminates all activity by " { $link irc-client } " cleaning up resources and notifying listeners." } ;
+{ $description "Terminates all activity by " { $link irc-client } " cleaning up resources and notifying chats." } ;
-HELP: write-message "Sends a message through a listener"
-{ $values { "message" "a string or irc message object" } { "irc-listener" "an irc listener object" } }
-{ $description "Sends " { $snippet "message" } " through " { $snippet "irc-listener" } ". Strings are automatically promoted to privmsg objects." } ;
+HELP: speak "Sends a message through a chat"
+{ $values { "message" "a string or irc message object" } { "irc-chat" "an irc chat object" } }
+{ $description "Sends " { $snippet "message" } " through " { $snippet "irc-chat" } ". Strings are automatically promoted to privmsg objects." } ;
-HELP: read-message "Reads a message from a listener"
-{ $values { "irc-listener" "an irc listener object" } { "message" "an irc message object" } }
-{ $description "Reads " { $snippet "message" } " from " { $snippet "irc-listener" } "." } ;
+HELP: hear "Reads a message from a chat"
+{ $values { "irc-chat" "an irc chat object" } { "message" "an irc message object" } }
+{ $description "Reads " { $snippet "message" } " from " { $snippet "irc-chat" } "." } ;
ARTICLE: "irc.client" "IRC Client"
"An IRC Client library"
{ $heading "IRC objects:" }
{ $subsection irc-client }
-{ $heading "Listener objects:" }
-{ $subsection irc-server-listener }
-{ $subsection irc-channel-listener }
-{ $subsection irc-nick-listener }
+{ $heading "Chat objects:" }
+{ $subsection irc-server-chat }
+{ $subsection irc-channel-chat }
+{ $subsection irc-nick-chat }
{ $heading "Setup objects:" }
{ $subsection irc-profile }
{ $heading "Words:" }
{ $subsection connect-irc }
{ $subsection terminate-irc }
-{ $subsection add-listener }
-{ $subsection remove-listener }
-{ $subsection read-message }
-{ $subsection write-message }
+{ $subsection attach-chat }
+{ $subsection detach-chat }
+{ $subsection hear }
+{ $subsection speak }
{ $heading "IRC messages" }
"Some of the RFC defined irc messages as objects:"
{ $table
{ $heading "Special messages" }
"Some special messages that are created by the library and not by the irc server."
{ $table
- { { $link irc-end } " sent when the client isn't running anymore, listeners should stop after this." }
- { { $link irc-disconnected } " sent to notify listeners that connection was lost." }
- { { $link irc-connected } " sent to notify listeners that a connection with the irc server was established." } }
+ { { $link irc-chat-end } "sent to a chat when it has been detached from the client, the chat should stop after it receives this message. " }
+ { { $link irc-end } " sent when the client isn't running anymore, chats should stop after it receives this message." }
+ { { $link irc-disconnected } " sent to notify chats that connection was lost." }
+ { { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } }
{ $heading "Example:" }
{ $code
- "USING: irc.client concurrency.mailboxes ;"
+ "USING: irc.client ;"
"SYMBOL: bot"
"SYMBOL: mychannel"
"! Create the profile and client objects"
"\"irc.freenode.org\" irc-port \"mybot123\" f <irc-profile> <irc-client> bot set"
"! Connect to the server"
"bot get connect-irc"
- "! Create a channel listener"
- "\"#mychannel123\" <irc-channel-listener> mychannel set"
- "! Register and start listener (this joins the channel)"
- "mychannel get bot get add-listener"
+ "! Create a channel chat"
+ "\"#mychannel123\" <irc-channel-chat> mychannel set"
+ "! Register and start chat (this joins the channel)"
+ "mychannel get bot get attach-chat"
"! Send a message to the channel"
- "\"what's up?\" mychannel get write-message"
+ "\"what's up?\" mychannel get speak"
"! Read a message from the channel"
- "mychannel get read-message"
+ "mychannel get hear"
}
;
-ABOUT: "irc.client"
\ No newline at end of file
+ABOUT: "irc.client"
USING: kernel tools.test accessors arrays sequences qualified
- io io.streams.duplex namespaces threads
+ io io.streams.duplex namespaces threads destructors
calendar irc.client.private irc.client irc.messages.private
concurrency.mailboxes classes assocs combinators ;
EXCLUDE: irc.messages => join ;
M: mb-writer stream-nl ( mb-writer -- )
[ [ last-line>> concat ] [ lines>> ] bi push ] keep
V{ } clone >>last-line drop ;
+M: mb-reader dispose drop ;
+M: mb-writer dispose drop ;
: spawn-client ( -- irc-client )
"someserver" irc-port "factorbot" f <irc-profile>
<irc-client>
+ t >>is-ready
t >>is-running
<test-stream> >>stream
dup [ spawn-irc yield ] with-irc-client ;
! to be used inside with-irc-client quotations
-: %add-named-listener ( listener -- ) [ name>> ] keep set+run-listener ;
-: %join ( channel -- ) <irc-channel-listener> irc> add-listener ;
+: %add-named-chat ( chat -- ) irc> attach-chat ;
: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
+: %join ( channel -- ) <irc-channel-chat> irc> attach-chat ;
-: read-matching-message ( listener quot: ( msg -- ? ) -- irc-message )
+: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message )
[ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
: with-irc ( quot: ( -- ) -- )
! TESTS
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-[ { t } [ irc> profile>> nickname>> me? ] unit-test
+[ { t } [ irc> nick>> me? ] unit-test
- { "factorbot" } [ irc> profile>> nickname>> ] unit-test
+ { "factorbot" } [ irc> nick>> ] unit-test
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
! Test login and nickname set
[ { "factorbot2" } [
":some.where 001 factorbot2 :Welcome factorbot2" %push-line
- irc> profile>> nickname>>
+ irc> nick>>
+ ] unit-test
+] with-irc
+
+! Test connect
+{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
+ "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
+ [ 2drop <test-stream> t ] >>connect
+ [ connect-irc ] keep
+ stream>> [ in>> [ f ] dip push-line ] [ out>> lines>> ] bi
+] unit-test
+
+! Test join
+[ { "JOIN #factortest" } [
+ "#factortest" %join
+ irc> stream>> out>> lines>> pop
] unit-test
] with-irc
[ { join_ "#factortest" } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
{ ":factorbot!n=factorbo@some.where JOIN :#factortest"
":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
} [ %push-line ] each
- irc> join-messages>> 0.1 seconds mailbox-get-timeout
+ in-messages>> 0.1 seconds mailbox-get-timeout
[ class ] [ trailing>> ] bi
] unit-test
] with-irc
[ { T{ participant-changed f "somebody" +join+ } } [
- "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":somebody!n=somebody@some.where JOIN :#factortest" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
[ { privmsg "#factortest" "hello" } [
- "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
[ privmsg? ] read-matching-message
[ class ] [ name>> ] [ trailing>> ] tri
] with-irc
[ { privmsg "factorbot" "hello" } [
- "somedude" <irc-nick-listener> [ %add-named-listener ] keep
- ":somedude!n=user@isp.net PRIVMSG factorbot :hello" %push-line
+ "ircuser" <irc-nick-chat> [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line
[ privmsg? ] read-matching-message
[ class ] [ name>> ] [ trailing>> ] tri
] unit-test
] with-irc
[ { mode } [
- "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircserver.net MODE #factortest +ns" %push-line
[ mode? ] read-matching-message class
] unit-test
] with-irc
! Participant lists tests
-[ { H{ { "somedude" +normal+ } } } [
- "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
- ":somedude!n=user@isp.net JOIN :#factortest" %push-line
+[ { H{ { "ircuser" +normal+ } } } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net JOIN :#factortest" %push-line
participants>>
] unit-test
] with-irc
-[ { H{ { "somedude2" +normal+ } } } [
- "#factortest" <irc-channel-listener>
- H{ { "somedude2" +normal+ }
- { "somedude" +normal+ } } clone >>participants
- [ %add-named-listener ] keep
- ":somedude!n=user@isp.net PART #factortest" %push-line
+[ { H{ { "ircuser2" +normal+ } } } [
+ "#factortest" <irc-channel-chat>
+ H{ { "ircuser2" +normal+ }
+ { "ircuser" +normal+ } } clone >>participants
+ [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net PART #factortest" %push-line
participants>>
] unit-test
] with-irc
-[ { H{ { "somedude2" +normal+ } } } [
- "#factortest" <irc-channel-listener>
- H{ { "somedude2" +normal+ }
- { "somedude" +normal+ } } clone >>participants
- [ %add-named-listener ] keep
- ":somedude!n=user@isp.net QUIT" %push-line
+[ { H{ { "ircuser2" +normal+ } } } [
+ "#factortest" <irc-channel-chat>
+ H{ { "ircuser2" +normal+ }
+ { "ircuser" +normal+ } } clone >>participants
+ [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net QUIT" %push-line
participants>>
] unit-test
] with-irc
-[ { H{ { "somedude2" +normal+ } } } [
- "#factortest" <irc-channel-listener>
- H{ { "somedude2" +normal+ }
- { "somedude" +normal+ } } clone >>participants
- [ %add-named-listener ] keep
- ":somedude2!n=user2@isp.net KICK #factortest somedude" %push-line
+[ { H{ { "ircuser2" +normal+ } } } [
+ "#factortest" <irc-channel-chat>
+ H{ { "ircuser2" +normal+ }
+ { "ircuser" +normal+ } } clone >>participants
+ [ %add-named-chat ] keep
+ ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line
participants>>
] unit-test
] with-irc
-[ { H{ { "somedude2" +normal+ } } } [
- "#factortest" <irc-channel-listener>
- H{ { "somedude" +normal+ } } clone >>participants
- [ %add-named-listener ] keep
- ":somedude!n=user2@isp.net NICK :somedude2" %push-line
+[ { H{ { "ircuser2" +normal+ } } } [
+ "#factortest" <irc-channel-chat>
+ H{ { "ircuser" +normal+ } } clone >>participants
+ [ %add-named-chat ] keep
+ ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
participants>>
] unit-test
] with-irc
! Namelist change notification
[ { T{ participant-changed f f f f } } [
- "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
-[ { T{ participant-changed f "somedude" +part+ f } } [
- "#factortest" <irc-channel-listener>
- H{ { "somedude" +normal+ } } clone >>participants
- [ %add-named-listener ] keep
- ":somedude!n=user@isp.net QUIT" %push-line
+[ { T{ participant-changed f "ircuser" +part+ f } } [
+ "#factortest" <irc-channel-chat>
+ H{ { "ircuser" +normal+ } } clone >>participants
+ [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net QUIT" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
-[ { T{ participant-changed f "somedude" +nick+ "somedude2" } } [
- "#factortest" <irc-channel-listener>
- H{ { "somedude" +normal+ } } clone >>participants
- [ %add-named-listener ] keep
- ":somedude!n=user2@isp.net NICK :somedude2" %push-line
+[ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [
+ "#factortest" <irc-channel-chat>
+ H{ { "ircuser" +normal+ } } clone >>participants
+ [ %add-named-chat ] keep
+ ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile
-TUPLE: irc-client profile stream in-messages out-messages join-messages
- listeners is-running connect reconnect-time ;
-: <irc-client> ( profile -- irc-client )
- f <mailbox> <mailbox> <mailbox> H{ } clone f
- [ <inet> latin1 <client> ] 15 seconds irc-client boa ;
+TUPLE: irc-client profile stream in-messages out-messages
+ chats is-running nick connect reconnect-time is-ready ;
-TUPLE: irc-listener in-messages out-messages ;
-TUPLE: irc-server-listener < irc-listener ;
-TUPLE: irc-channel-listener < irc-listener name password timeout participants ;
-TUPLE: irc-nick-listener < irc-listener name ;
-SYMBOL: +server-listener+
+: <irc-client> ( profile -- irc-client )
+ irc-client new
+ swap >>profile
+ <mailbox> >>in-messages
+ <mailbox> >>out-messages
+ H{ } clone >>chats
+ dup profile>> nickname>> >>nick
+ [ <inet> latin1 <client> ] >>connect
+ 15 seconds >>reconnect-time ;
+
+TUPLE: irc-chat in-messages client ;
+TUPLE: irc-server-chat < irc-chat ;
+TUPLE: irc-channel-chat < irc-chat name password timeout participants ;
+TUPLE: irc-nick-chat < irc-chat name ;
+SYMBOL: +server-chat+
! participant modes
SYMBOL: +operator+
SYMBOL: +mode+
SYMBOL: +nick+
-! listener objects
-: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
-
-: <irc-server-listener> ( -- irc-server-listener )
- <mailbox> <mailbox> irc-server-listener boa ;
+! chat objects
+: <irc-server-chat> ( -- irc-server-chat )
+ <mailbox> f irc-server-chat boa ;
-: <irc-channel-listener> ( name -- irc-channel-listener )
- [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone
- irc-channel-listener boa ;
+: <irc-channel-chat> ( name -- irc-channel-chat )
+ [ <mailbox> f ] dip f 60 seconds H{ } clone
+ irc-channel-chat boa ;
-: <irc-nick-listener> ( name -- irc-nick-listener )
- [ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
+: <irc-nick-chat> ( name -- irc-nick-chat )
+ [ <mailbox> f ] dip irc-nick-chat boa ;
! ======================================
! Message objects
TUPLE: participant-changed nick action parameter ;
C: <participant-changed> participant-changed
-SINGLETON: irc-listener-end ! send to a listener to stop its execution
+SINGLETON: irc-chat-end ! sent to a chat to stop its execution
SINGLETON: irc-end ! sent when the client isn't running anymore
SINGLETON: irc-disconnected ! sent when connection is lost
SINGLETON: irc-connected ! sent when connection is established
-<PRIVATE
-: end-loops ( irc-client -- )
- [ listeners>> values [ out-messages>> ] map ]
- [ in-messages>> ]
- [ out-messages>> ] tri 2array prepend
- [ irc-end swap mailbox-put ] each ;
-PRIVATE>
-
: terminate-irc ( irc-client -- )
[ is-running>> ] keep and [
- [ end-loops ] [ [ f ] dip (>>is-running) ] bi
+ f >>is-running
+ [ stream>> dispose ] keep
+ [ in-messages>> ] [ out-messages>> ] bi 2array
+ [ irc-end swap mailbox-put ] each
] when* ;
<PRIVATE
! ======================================
: irc> ( -- irc-client ) current-irc-client get ;
-: irc-stream> ( -- stream ) irc> stream>> ;
-: irc-write ( s -- ) irc-stream> stream-write ;
-: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
+: irc-write ( s -- ) irc> stream>> stream-write ;
+: irc-print ( s -- ) irc> stream>> [ stream-print ] keep stream-flush ;
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
-: listener> ( name -- listener/f ) irc> listeners>> at ;
+: chat> ( name -- chat/f ) irc> chats>> at ;
: channel-mode? ( mode -- ? ) name>> first "#&" member? ;
-: me? ( string -- ? ) irc> profile>> nickname>> = ;
+: me? ( string -- ? ) irc> nick>> = ;
-GENERIC: to-listener ( message obj -- )
+GENERIC: to-chat ( message obj -- )
-M: string to-listener ( message string -- )
- listener> [ +server-listener+ listener> ] unless*
- [ to-listener ] [ drop ] if* ;
+M: string to-chat
+ chat> [ +server-chat+ chat> ] unless*
+ [ to-chat ] [ drop ] if* ;
-M: irc-listener to-listener ( message irc-listener -- )
- in-messages>> mailbox-put ;
+M: irc-chat to-chat in-messages>> mailbox-put ;
-: unregister-listener ( name -- )
- irc> listeners>>
- [ at [ irc-listener-end ] dip to-listener ]
+: unregister-chat ( name -- )
+ irc> chats>>
+ [ at [ irc-chat-end ] dip to-chat ]
[ delete-at ]
2bi ;
-: (remove-participant) ( nick listener -- )
+: (remove-participant) ( nick chat -- )
[ participants>> delete-at ]
- [ [ +part+ f <participant-changed> ] dip to-listener ] 2bi ;
+ [ [ +part+ f <participant-changed> ] dip to-chat ] 2bi ;
: remove-participant ( nick channel -- )
- listener> [ (remove-participant) ] [ drop ] if* ;
+ chat> [ (remove-participant) ] [ drop ] if* ;
-: listeners-with-participant ( nick -- seq )
- irc> listeners>> values
- [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
+: chats-with-participant ( nick -- seq )
+ irc> chats>> values
+ [ [ irc-channel-chat? ] keep and [ participants>> key? ] [ drop f ] if* ]
with filter ;
-: to-listeners-with-participant ( message nickname -- )
- listeners-with-participant [ to-listener ] with each ;
+: to-chats-with-participant ( message nickname -- )
+ chats-with-participant [ to-chat ] with each ;
: remove-participant-from-all ( nick -- )
- dup listeners-with-participant [ (remove-participant) ] with each ;
+ dup chats-with-participant [ (remove-participant) ] with each ;
-: notify-rename ( newnick oldnick listener -- )
+: notify-rename ( newnick oldnick chat -- )
[ participant-changed new +nick+ >>action
- [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-listener ;
+ [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-chat ;
-: rename-participant ( newnick oldnick listener -- )
- [ participants>> [ delete-at* drop ] [ [ swap ] dip set-at ] bi ]
+: rename-participant ( newnick oldnick chat -- )
+ [ participants>> [ delete-at* drop ] [ swapd set-at ] bi ]
[ notify-rename ] 3bi ;
: rename-participant-in-all ( oldnick newnick -- )
- swap dup listeners-with-participant [ rename-participant ] with with each ;
+ swap dup chats-with-participant [ rename-participant ] with with each ;
: add-participant ( mode nick channel -- )
- listener>
+ chat>
[ participants>> set-at ]
- [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi ;
+ [ [ +join+ f <participant-changed> ] dip to-chat ] 2bi ;
: change-participant-mode ( channel mode nick -- )
- rot listener>
+ rot chat>
[ participants>> set-at ]
- [ [ [ +mode+ ] dip <participant-changed> ] dip to-listener ] 3bi ; ! FIXME
+ [ [ [ +mode+ ] dip <participant-changed> ] dip to-chat ] 3bi ; ! FIXME
DEFER: me?
-: maybe-forward-join ( join -- )
- [ irc-message-sender me? ] keep and
- [ irc> join-messages>> mailbox-put ] when* ;
-
! ======================================
! IRC client messages
! ======================================
! Server message handling
! ======================================
+GENERIC: initialize-chat ( chat -- )
+M: irc-chat initialize-chat drop ;
+M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
+
GENERIC: forward-name ( irc-message -- name )
-M: join forward-name ( join -- name ) trailing>> ;
-M: part forward-name ( part -- name ) channel>> ;
-M: kick forward-name ( kick -- name ) channel>> ;
-M: mode forward-name ( mode -- name ) name>> ;
-M: privmsg forward-name ( privmsg -- name )
- dup name>> me? [ irc-message-sender ] [ name>> ] if ;
+M: join forward-name trailing>> ;
+M: part forward-name channel>> ;
+M: kick forward-name channel>> ;
+M: mode forward-name name>> ;
+M: privmsg forward-name dup name>> me? [ irc-message-sender ] [ name>> ] if ;
UNION: single-forward join part kick mode privmsg ;
UNION: multiple-forward nick quit ;
UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
GENERIC: forward-message ( irc-message -- )
-M: irc-message forward-message ( irc-message -- )
- +server-listener+ listener> [ to-listener ] [ drop ] if* ;
-
-M: single-forward forward-message ( forward-single -- )
- dup forward-name to-listener ;
+M: irc-message forward-message
+ +server-chat+ chat> [ to-chat ] [ drop ] if* ;
-M: multiple-forward forward-message ( multiple-forward -- )
- dup irc-message-sender to-listeners-with-participant ;
+M: single-forward forward-message dup forward-name to-chat ;
-M: join forward-message ( join -- )
- [ maybe-forward-join ] [ call-next-method ] bi ;
-
-M: broadcast-forward forward-message ( irc-broadcasted-message -- )
- irc> listeners>> values [ to-listener ] with each ;
+M: multiple-forward forward-message
+ dup irc-message-sender to-chats-with-participant ;
+
+M: broadcast-forward forward-message
+ irc> chats>> values [ to-chat ] with each ;
GENERIC: process-message ( irc-message -- )
-
-M: object process-message ( object -- )
- drop ;
-
-M: logged-in process-message ( logged-in -- )
- name>> irc> profile>> (>>nickname) ;
-
-M: ping process-message ( ping -- )
- trailing>> /PONG ;
-
-M: nick-in-use process-message ( nick-in-use -- )
- name>> "_" append /NICK ;
-
-M: join process-message ( join -- )
+M: object process-message drop ;
+M: logged-in process-message
+ name>> f irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
+ values [ initialize-chat ] each ;
+M: ping process-message trailing>> /PONG ;
+M: nick-in-use process-message name>> "_" append /NICK ;
+
+M: join process-message
[ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
- dup listener> [ add-participant ] [ 3drop ] if ;
+ dup chat> [ add-participant ] [ 3drop ] if ;
-M: part process-message ( part -- )
+M: part process-message
[ irc-message-sender ] [ channel>> ] bi remove-participant ;
-M: kick process-message ( kick -- )
+M: kick process-message
[ [ who>> ] [ channel>> ] bi remove-participant ]
- [ dup who>> me? [ unregister-listener ] [ drop ] if ]
+ [ dup who>> me? [ unregister-chat ] [ drop ] if ]
bi ;
-M: quit process-message ( quit -- )
+M: quit process-message
irc-message-sender remove-participant-from-all ;
-M: nick process-message ( nick -- )
+M: nick process-message
[ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
! M: mode process-message ( mode -- )
trailing>> [ blank? ] trim " " split
[ >nick/mode 2array ] map >hashtable ;
-M: names-reply process-message ( names-reply -- )
- [ names-reply>participants ] [ channel>> listener> ] bi [
+M: names-reply process-message
+ [ names-reply>participants ] [ channel>> chat> ] bi [
[ (>>participants) ]
- [ [ f f f <participant-changed> ] dip name>> to-listener ] bi
+ [ [ f f f <participant-changed> ] dip name>> to-chat ] bi
] [ drop ] if* ;
! ======================================
! ======================================
GENERIC: handle-outgoing-irc ( irc-message -- ? )
-M: irc-end handle-outgoing-irc ( irc-end -- ? ) drop f ;
-M: irc-message handle-outgoing-irc ( irc-message -- ? )
- irc-message>client-line irc-print t ;
+M: irc-end handle-outgoing-irc drop f ;
+M: irc-message handle-outgoing-irc irc-message>client-line irc-print t ;
! ======================================
! Reader/Writer
irc>
[ [ irc-disconnected ] dip in-messages>> mailbox-put ]
[ dup reconnect-time>> sleep (connect-irc) ]
- [ profile>> nickname>> /LOGIN ]
+ [ nick>> /LOGIN ]
tri ;
! FIXME: do something with the exception, store somewhere to help debugging
-: handle-disconnect ( error -- )
- drop irc> is-running>> [ (handle-disconnect) ] when ;
+: handle-disconnect ( error -- ? )
+ drop irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
: (reader-loop) ( -- ? )
irc> stream>> [
] with-destructors ;
: reader-loop ( -- ? )
- [ (reader-loop) ] [ handle-disconnect t ] recover ;
+ [ (reader-loop) ] [ handle-disconnect ] recover ;
: writer-loop ( -- ? )
irc> out-messages>> mailbox-get handle-outgoing-irc ;
[ nip ]
} cond ;
-GENERIC: handle-listener-out ( irc-message -- ? )
-M: irc-end handle-listener-out ( irc-end -- ? ) drop f ;
-M: irc-message handle-listener-out ( irc-message -- ? )
- irc> out-messages>> mailbox-put t ;
-
-: listener-loop ( name -- ? )
- dup listener> [
- out-messages>> mailbox-get
- maybe-annotate-with-name handle-listener-out
- ] [ drop f ] if* ;
+GENERIC: annotate-message ( chat object -- object )
+M: object annotate-message nip ;
+M: part annotate-message swap name>> >>channel ;
+M: privmsg annotate-message swap name>> >>name ;
+M: string annotate-message [ name>> ] dip strings>privmsg ;
: spawn-irc ( -- )
[ reader-loop ] "irc-reader-loop" spawn-server
[ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
3drop ;
-! ======================================
-! Listener join request handling
-! ======================================
-
-: set+run-listener ( name irc-listener -- )
- over irc> listeners>> set-at
- '[ _ listener-loop ] "irc-listener-loop" spawn-server drop ;
-
-GENERIC: (add-listener) ( irc-listener -- )
-
-M: irc-channel-listener (add-listener) ( irc-channel-listener -- )
- [ [ name>> ] [ password>> ] bi /JOIN ]
- [ [ [ drop irc> join-messages>> ]
- [ timeout>> ]
- [ name>> '[ trailing>> _ = ] ]
- tri mailbox-get-timeout? trailing>> ] keep set+run-listener
- ] bi ;
-
-M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
- [ name>> ] keep set+run-listener ;
+GENERIC: (attach-chat) ( irc-chat -- )
+USE: prettyprint
+M: irc-chat (attach-chat)
+ [ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ]
+ [ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ]
+ bi ;
-M: irc-server-listener (add-listener) ( irc-server-listener -- )
- [ +server-listener+ ] dip set+run-listener ;
+M: irc-server-chat (attach-chat)
+ irc> >>client +server-chat+ irc> chats>> set-at ;
-GENERIC: (remove-listener) ( irc-listener -- )
+GENERIC: (remove-chat) ( irc-chat -- )
-M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
- name>> unregister-listener ;
+M: irc-nick-chat (remove-chat)
+ name>> unregister-chat ;
-M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
- [ [ name>> ] [ out-messages>> ] bi
- [ [ part new ] dip >>channel ] dip mailbox-put ] keep
- name>> unregister-listener ;
+M: irc-channel-chat (remove-chat)
+ [ part new annotate-message irc> out-messages>> mailbox-put ] keep
+ name>> unregister-chat ;
-M: irc-server-listener (remove-listener) ( irc-server-listener -- )
- drop +server-listener+ unregister-listener ;
+M: irc-server-chat (remove-chat)
+ drop +server-chat+ unregister-chat ;
: (connect-irc) ( irc-client -- )
- [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
- swap >>stream
- t >>is-running
- in-messages>> [ irc-connected ] dip mailbox-put ;
+ {
+ [ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
+ [ (>>stream) ]
+ [ t swap (>>is-running) ]
+ [ in-messages>> [ irc-connected ] dip mailbox-put ]
+ } cleave ;
: with-irc-client ( irc-client quot: ( -- ) -- )
[ \ current-irc-client ] dip with-variable ; inline
PRIVATE>
: connect-irc ( irc-client -- )
- [ irc>
- [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
- spawn-irc ] with-irc-client ;
+ dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ;
+
+: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ;
-: add-listener ( irc-listener irc-client -- )
- swap '[ _ (add-listener) ] with-irc-client ;
+: detach-chat ( irc-chat -- )
+ [ client>> ] keep '[ _ (remove-chat) ] with-irc-client ;
-: remove-listener ( irc-listener irc-client -- )
- swap '[ _ (remove-listener) ] with-irc-client ;
+: speak ( message irc-chat -- )
+ [ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ;
-: write-message ( message irc-listener -- ) out-messages>> mailbox-put ;
-: read-message ( irc-listener -- message ) in-messages>> mailbox-get ;
+: hear ( irc-chat -- message ) in-messages>> mailbox-get ;
{ parameters { } }
{ trailing "someuser2" } } }
[ ":someuser!n=user@some.where NICK :someuser2"
+ parse-irc-line f >>timestamp ] unit-test
+
+{ T{ nick-in-use
+ { line ":ircserver.net 433 * nickname :Nickname is already in use" }
+ { prefix "ircserver.net" }
+ { command "433" }
+ { parameters { "*" "nickname" } }
+ { name "nickname" }
+ { trailing "Nickname is already in use" } } }
+[ ":ircserver.net 433 * nickname :Nickname is already in use"
parse-irc-line f >>timestamp ] unit-test
\ No newline at end of file
arrays classes.tuple math.order ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ;
-EXCLUDE: inverse => _ ;
IN: irc.messages
TUPLE: irc-message line prefix command parameters trailing timestamp ;
TUPLE: privmsg < irc-message name ;
TUPLE: kick < irc-message channel who ;
TUPLE: roomlist < irc-message channel names ;
-TUPLE: nick-in-use < irc-message asterisk name ;
+TUPLE: nick-in-use < irc-message name ;
TUPLE: notice < irc-message type ;
TUPLE: mode < irc-message name mode parameter ;
TUPLE: names-reply < irc-message who channel ;
TUPLE: unhandled < irc-message ;
: <irc-client-message> ( command parameters trailing -- irc-message )
- irc-message new now >>timestamp
- [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ;
+ irc-message new
+ now >>timestamp
+ swap >>trailing
+ swap >>parameters
+ swap >>command ;
<PRIVATE
M: mode command-parameters>> ( mode -- seq )
[ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
-GENERIC: (>>command-parameters) ( params irc-message -- )
-
-M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ;
-M: logged-in (>>command-parameters) ( params part -- ) [ first ] dip (>>name) ;
-M: privmsg (>>command-parameters) ( params privmsg -- ) [ first ] dip (>>name) ;
-M: notice (>>command-parameters) ( params notice -- ) [ first ] dip (>>type) ;
-M: part (>>command-parameters) ( params part -- )
- [ first ] dip (>>channel) ;
-M: kick (>>command-parameters) ( params kick -- )
- [ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ;
-M: names-reply (>>command-parameters) ( params names-reply -- )
- [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ;
-M: mode (>>command-parameters) ( params mode -- )
- { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] }
- { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] }
- } switch ;
+GENERIC# >>command-parameters 1 ( irc-message params -- irc-message )
+
+M: irc-message >>command-parameters ( irc-message params -- irc-message )
+ drop ;
+
+M: logged-in >>command-parameters ( part params -- part )
+ first >>name ;
+
+M: privmsg >>command-parameters ( privmsg params -- privmsg )
+ first >>name ;
+
+M: notice >>command-parameters ( notice params -- notice )
+ first >>type ;
+
+M: part >>command-parameters ( part params -- part )
+ first >>channel ;
+
+M: kick >>command-parameters ( kick params -- kick )
+ first2 [ >>channel ] [ >>who ] bi* ;
+
+M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use )
+ second >>name ;
+
+M: names-reply >>command-parameters ( names-reply params -- names-reply )
+ first3 nip [ >>who ] [ >>channel ] bi* ;
+
+M: mode >>command-parameters ( mode params -- mode )
+ dup length 3 = [
+ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri*
+ ] [
+ first2 [ >>name ] [ >>mode ] bi*
+ ] if ;
PRIVATE>
drop "not implemented yet" ;
<PRIVATE
+
! ======================================
! Message parsing
! ======================================
: split-at-first ( seq separators -- before after )
dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
-: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
+: remove-heading-: ( seq -- seq )
+ ":" ?head drop ;
: parse-name ( string -- string )
remove-heading-: "!" split-at-first drop ;
: split-prefix ( string -- string/f string )
dup ":" head?
- [ remove-heading-: " " split1 ]
- [ f swap ]
- if ;
+ [ remove-heading-: " " split1 ] [ f swap ] if ;
: split-trailing ( string -- string string/f )
":" split1 ;
-: copy-message-in ( origin dest -- )
- { [ [ parameters>> ] dip [ (>>command-parameters) ] [ (>>parameters) ] 2bi ]
- [ [ line>> ] dip (>>line) ]
- [ [ prefix>> ] dip (>>prefix) ]
- [ [ command>> ] dip (>>command) ]
- [ [ trailing>> ] dip (>>trailing) ]
- [ [ timestamp>> ] dip (>>timestamp) ]
- } 2cleave ;
+: copy-message-in ( command irc-message -- command )
+ {
+ [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
+ [ line>> >>line ]
+ [ prefix>> >>prefix ]
+ [ command>> >>command ]
+ [ trailing>> >>trailing ]
+ [ timestamp>> >>timestamp ]
+ } cleave ;
PRIVATE>
[ [ blank? ] trim " " split unclip swap ] dip
now irc-message boa ;
+: irc-message>command ( irc-message -- command )
+ [
+ command>> {
+ { "PING" [ ping ] }
+ { "NOTICE" [ notice ] }
+ { "001" [ logged-in ] }
+ { "433" [ nick-in-use ] }
+ { "353" [ names-reply ] }
+ { "JOIN" [ join ] }
+ { "PART" [ part ] }
+ { "NICK" [ nick ] }
+ { "PRIVMSG" [ privmsg ] }
+ { "QUIT" [ quit ] }
+ { "MODE" [ mode ] }
+ { "KICK" [ kick ] }
+ [ drop unhandled ]
+ } case new
+ ] keep copy-message-in ;
+
: parse-irc-line ( string -- message )
- string>irc-message
- dup command>> {
- { "PING" [ ping ] }
- { "NOTICE" [ notice ] }
- { "001" [ logged-in ] }
- { "433" [ nick-in-use ] }
- { "353" [ names-reply ] }
- { "JOIN" [ join ] }
- { "PART" [ part ] }
- { "NICK" [ nick ] }
- { "PRIVMSG" [ privmsg ] }
- { "QUIT" [ quit ] }
- { "MODE" [ mode ] }
- { "KICK" [ kick ] }
- [ drop unhandled ]
- } case new [ copy-message-in ] keep ;
+ string>irc-message irc-message>command ;
: say ( string -- )\r
irc-tab get\r
[ window>> client>> profile>> nickname>> <own-message> print-irc ]\r
- [ listener>> write-message ] 2bi ;\r
+ [ chat>> speak ] 2bi ;\r
\r
: join ( string -- )\r
irc-tab get window>> join-channel ;\r
\r
: whois ( string -- )\r
"WHOIS" swap { } clone swap <irc-client-message>\r
- irc-tab get listener>> write-message ;\r
+ irc-tab get listener>> speak ;\r
\r
: quote ( string -- )\r
drop ; ! THIS WILL CHANGE\r
\r
IN: irc.ui\r
\r
-SYMBOL: listener\r
+SYMBOL: chat\r
\r
SYMBOL: client\r
\r
M: ui-window ungraft*\r
client>> terminate-irc ;\r
\r
-TUPLE: irc-tab < frame listener client window ;\r
+TUPLE: irc-tab < frame chat client window ;\r
\r
: write-color ( str color -- )\r
foreground associate format ;\r
M: irc-connected write-irc\r
drop "* Connected" dark-green write-color ;\r
\r
-M: irc-listener-end write-irc\r
+M: irc-chat-end write-irc\r
drop ;\r
\r
M: irc-message write-irc\r
\r
: send-message ( message -- )\r
[ print-irc ]\r
- [ listener get write-message ] bi ;\r
+ [ chat get speak ] bi ;\r
\r
GENERIC: handle-inbox ( tab message -- )\r
\r
\r
: display ( stream tab -- )\r
'[ _ [ [ t ]\r
- [ _ dup listener>> read-message handle-inbox ]\r
+ [ _ dup chat>> hear handle-inbox ]\r
[ ] while ] with-output-stream ] "ircv" spawn drop ;\r
\r
: <irc-pane> ( tab -- tab pane )\r
{ T{ key-down f f "ENTER" } editor-send }\r
} define-command-map\r
\r
-: new-irc-tab ( listener ui-window class -- irc-tab )\r
+: new-irc-tab ( chat ui-window class -- irc-tab )\r
new-frame\r
swap >>window\r
- swap >>listener\r
+ swap >>chat\r
<irc-pane> [ <scroller> @center grid-add ] keep\r
<irc-editor> <scroller> @bottom grid-add ;\r
\r
M: irc-tab graft*\r
- [ listener>> ] [ window>> client>> ] bi add-listener ;\r
+ [ chat>> ] [ window>> client>> ] bi attach-chat ;\r
\r
M: irc-tab ungraft*\r
- [ listener>> ] [ window>> client>> ] bi remove-listener ;\r
+ chat>> detach-chat ;\r
\r
TUPLE: irc-channel-tab < irc-tab userlist ;\r
\r
-: <irc-channel-tab> ( listener ui-window -- irc-tab )\r
+: <irc-channel-tab> ( chat ui-window -- irc-tab )\r
irc-channel-tab new-irc-tab\r
<pile> [ <scroller> @right grid-add ] keep >>userlist ;\r
\r
: update-participants ( tab -- )\r
[ userlist>> [ clear-gadget ] keep ]\r
- [ listener>> participants>> ] bi\r
+ [ chat>> participants>> ] bi\r
[ +operator+ value-labels dark-green add-gadget-color ]\r
[ +voice+ value-labels blue add-gadget-color ]\r
[ +normal+ value-labels black add-gadget-color ] tri drop ;\r
\r
TUPLE: irc-server-tab < irc-tab ;\r
\r
-: <irc-server-tab> ( listener -- irc-tab )\r
+: <irc-server-tab> ( chat -- irc-tab )\r
f irc-server-tab new-irc-tab ;\r
\r
-: <irc-nick-tab> ( listener ui-window -- irc-tab )\r
+: <irc-nick-tab> ( chat ui-window -- irc-tab )\r
irc-tab new-irc-tab ;\r
\r
M: irc-tab pref-dim*\r
drop { 480 480 } ;\r
\r
: join-channel ( name ui-window -- )\r
- [ dup <irc-channel-listener> ] dip\r
+ [ dup <irc-channel-chat> ] dip\r
[ <irc-channel-tab> swap ] keep\r
add-page ;\r
\r
: query-nick ( nick ui-window -- )\r
- [ dup <irc-nick-listener> ] dip\r
+ [ dup <irc-nick-chat> ] dip\r
[ <irc-nick-tab> swap ] keep\r
add-page ;\r
\r
\r
: ui-connect ( profile -- ui-window )\r
<irc-client>\r
- { [ [ <irc-server-listener> ] dip add-listener ]\r
- [ listeners>> +server-listener+ swap at <irc-server-tab> dup\r
+ { [ [ <irc-server-chat> ] dip attach-chat ]\r
+ [ chats>> +server-chat+ swap at <irc-server-tab> dup\r
"Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]\r
[ >>client ]\r
[ connect-irc ] } cleave ;\r
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-name "Jamshred" }
+}
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
+IN: jamshred.game
+
+TUPLE: jamshred sounds tunnel players running quit ;
+
+: <jamshred> ( -- jamshred )
+ <sounds> <random-tunnel> "Player 1" pick <player>
+ 2dup swap play-in-tunnel 1array f f jamshred boa ;
+
+: jamshred-player ( jamshred -- player )
+ ! TODO: support more than one player
+ players>> first ;
+
+: jamshred-update ( jamshred -- )
+ dup running>> [
+ jamshred-player update-player
+ ] [ drop ] if ;
+
+: toggle-running ( jamshred -- )
+ dup running>> [
+ f >>running drop
+ ] [
+ [ jamshred-player moved ]
+ [ t >>running drop ] bi
+ ] if ;
+
+: mouse-moved ( x-radians y-radians jamshred -- )
+ jamshred-player -rot turn-player ;
+
+: units-per-full-roll ( -- n ) 50 ;
+
+: jamshred-roll ( jamshred n -- )
+ [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
+
+: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
+
+: mouse-scroll-y ( jamshred y -- )
+ neg swap jamshred-player change-player-speed ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences float-arrays ;
+IN: jamshred.gl
+
+: min-vertices 6 ; inline
+: max-vertices 32 ; inline
+
+: n-vertices ( -- n ) 32 ; inline
+
+! render enough of the tunnel that it looks continuous
+: n-segments-ahead ( -- n ) 60 ; inline
+: n-segments-behind ( -- n ) 40 ; inline
+
+: wall-drawing-offset ( -- n )
+ #! so that we can't see through the wall, we draw it a bit further away
+ 0.15 ;
+
+: wall-drawing-radius ( segment -- r )
+ radius>> wall-drawing-offset + ;
+
+: wall-up ( segment -- v )
+ [ wall-drawing-radius ] [ up>> ] bi n*v ;
+
+: wall-left ( segment -- v )
+ [ wall-drawing-radius ] [ left>> ] bi n*v ;
+
+: segment-vertex ( theta segment -- vertex )
+ [
+ [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
+ ] [
+ location>> v+
+ ] bi ;
+
+: segment-vertex-normal ( vertex segment -- normal )
+ location>> swap v- normalize ;
+
+: segment-vertex-and-normal ( segment theta -- vertex normal )
+ swap [ segment-vertex ] keep dupd segment-vertex-normal ;
+
+: equally-spaced-radians ( n -- seq )
+ #! return a sequence of n numbers between 0 and 2pi
+ dup [ / pi 2 * * ] curry map ;
+
+: draw-segment-vertex ( segment theta -- )
+ over color>> set-color segment-vertex-and-normal
+ gl-normal gl-vertex ;
+
+: draw-vertex-pair ( theta next-segment segment -- )
+ rot tuck draw-segment-vertex draw-segment-vertex ;
+
+: draw-segment ( next-segment segment -- )
+ GL_QUAD_STRIP [
+ [ draw-vertex-pair ] 2curry
+ n-vertices equally-spaced-radians F{ 0.0 } append swap each
+ ] do-state ;
+
+: draw-segments ( segments -- )
+ 1 over length pick subseq swap [ draw-segment ] 2each ;
+
+: segments-to-render ( player -- segments )
+ dup nearest-segment>> number>> dup n-segments-behind -
+ swap n-segments-ahead + rot tunnel>> sub-tunnel ;
+
+: draw-tunnel ( player -- )
+ segments-to-render draw-segments ;
+
+: init-graphics ( width height -- )
+ GL_DEPTH_TEST glEnable
+ GL_SCISSOR_TEST glDisable
+ 1.0 glClearDepth
+ 0.0 0.0 0.0 0.0 glClearColor
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+ GL_PROJECTION glMatrixMode glLoadIdentity
+ dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if
+ GL_MODELVIEW glMatrixMode glLoadIdentity
+ GL_LEQUAL glDepthFunc
+ GL_LIGHTING glEnable
+ GL_LIGHT0 glEnable
+ GL_FOG glEnable
+ GL_FOG_DENSITY 0.09 glFogf
+ GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
+ GL_COLOR_MATERIAL glEnable
+ GL_LIGHT0 GL_POSITION F{ 0.0 0.0 0.0 1.0 } >c-float-array glLightfv
+ GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv
+ GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv
+ GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ;
+
+: player-view ( player -- )
+ [ location>> ]
+ [ [ location>> ] [ forward>> ] bi v+ ]
+ [ up>> ] tri gl-look-at ;
+
+: draw-jamshred ( jamshred width height -- )
+ init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ;
+
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.geometry.rect math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
+IN: jamshred
+
+TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
+
+: <jamshred-gadget> ( jamshred -- gadget )
+ jamshred-gadget new-gadget swap >>jamshred ;
+
+: default-width ( -- x ) 800 ;
+: default-height ( -- y ) 600 ;
+
+M: jamshred-gadget pref-dim*
+ drop default-width default-height 2array ;
+
+M: jamshred-gadget draw-gadget* ( gadget -- )
+ [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
+
+: jamshred-loop ( gadget -- )
+ dup jamshred>> quit>> [
+ drop
+ ] [
+ [ jamshred>> jamshred-update ]
+ [ relayout-1 ]
+ [ 10 sleep yield jamshred-loop ] tri
+ ] if ;
+
+: fullscreen ( gadget -- )
+ find-world t swap set-fullscreen* ;
+
+: no-fullscreen ( gadget -- )
+ find-world f swap set-fullscreen* ;
+
+: toggle-fullscreen ( world -- )
+ [ fullscreen? not ] keep set-fullscreen* ;
+
+M: jamshred-gadget graft* ( gadget -- )
+ [ jamshred-loop ] curry in-thread ;
+
+M: jamshred-gadget ungraft* ( gadget -- )
+ jamshred>> t swap (>>quit) ;
+
+: jamshred-restart ( jamshred-gadget -- )
+ <jamshred> >>jamshred drop ;
+
+: pix>radians ( n m -- theta )
+ / pi 4 * * ; ! 2 / / pi 2 * * ;
+
+: x>radians ( x gadget -- theta )
+ #! translate motion of x pixels to an angle
+ rect-dim first pix>radians neg ;
+
+: y>radians ( y gadget -- theta )
+ #! translate motion of y pixels to an angle
+ rect-dim second pix>radians ;
+
+: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
+ over jamshred>> >r
+ [ first swap x>radians ] 2keep second swap y>radians
+ r> mouse-moved ;
+
+: handle-mouse-motion ( jamshred-gadget -- )
+ hand-loc get [
+ over last-hand-loc>> [
+ v- (handle-mouse-motion)
+ ] [ 2drop ] if*
+ ] 2keep >>last-hand-loc drop ;
+
+: handle-mouse-scroll ( jamshred-gadget -- )
+ jamshred>> scroll-direction get
+ [ first mouse-scroll-x ]
+ [ second mouse-scroll-y ] 2bi ;
+
+: quit ( gadget -- )
+ [ no-fullscreen ] [ close-window ] bi ;
+
+jamshred-gadget H{
+ { T{ key-down f f "r" } [ jamshred-restart ] }
+ { T{ key-down f f " " } [ jamshred>> toggle-running ] }
+ { T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
+ { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
+ { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
+ { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
+ { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
+ { T{ key-down f f "q" } [ quit ] }
+ { T{ motion } [ handle-mouse-motion ] }
+ { T{ mouse-scroll } [ handle-mouse-scroll ] }
+} set-gestures
+
+: jamshred-window ( -- gadget )
+ [ <jamshred> <jamshred-gadget> dup "Jamshred" open-window ] with-ui ;
+
+MAIN: jamshred-window
--- /dev/null
+USING: kernel logging ;
+IN: jamshred.log
+
+LOG: (jamshred-log) DEBUG
+
+: with-jamshred-log ( quot -- )
+ "jamshred" swap with-logging ;
+
+: jamshred-log ( message -- )
+ [ (jamshred-log) ] with-jamshred-log ; ! ugly...
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: jamshred.oint tools.test ;
+IN: jamshred.oint-tests
+
+[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
+[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
+[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
+[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
+[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
+IN: jamshred.oint
+
+! An oint is a point with three linearly independent unit vectors
+! given relative to that point. In jamshred a player's location and
+! direction are given by the player's oint. Similarly, a tunnel
+! segment's location and orientation are given by an oint.
+
+TUPLE: oint location forward up left ;
+C: <oint> oint
+
+: rotation-quaternion ( theta axis -- quaternion )
+ swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
+
+: rotate-vector ( q qrecip v -- v )
+ v>q swap q* q* q>v ;
+
+: rotate-oint ( oint theta axis -- )
+ rotation-quaternion dup qrecip pick
+ [ forward>> rotate-vector >>forward ]
+ [ up>> rotate-vector >>up ]
+ [ left>> rotate-vector >>left ] 3tri drop ;
+
+: left-pivot ( oint theta -- )
+ over left>> rotate-oint ;
+
+: up-pivot ( oint theta -- )
+ over up>> rotate-oint ;
+
+: forward-pivot ( oint theta -- )
+ over forward>> rotate-oint ;
+
+: random-float+- ( n -- m )
+ #! find a random float between -n/2 and n/2
+ dup 10000 * >fixnum random 10000 / swap 2 / - ;
+
+: random-turn ( oint theta -- )
+ 2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
+
+: location+ ( v oint -- )
+ [ location>> v+ ] [ (>>location) ] bi ;
+
+: go-forward ( distance oint -- )
+ [ forward>> n*v ] [ location+ ] bi ;
+
+: distance-vector ( oint oint -- vector )
+ [ location>> ] bi@ swap v- ;
+
+: distance ( oint oint -- distance )
+ distance-vector norm ;
+
+: scalar-projection ( v1 v2 -- n )
+ #! the scalar projection of v1 onto v2
+ tuck v. swap norm / ;
+
+: proj-perp ( u v -- w )
+ dupd proj v- ;
+
+: perpendicular-distance ( oint oint -- distance )
+ tuck distance-vector swap 2dup left>> scalar-projection abs
+ -rot up>> scalar-projection abs + ;
+
+:: reflect ( v n -- v' )
+ #! bounce v on a surface with normal n
+ v v n v. n n v. / 2 * n n*v v- ;
+
+: half-way ( p1 p2 -- p3 )
+ over v- 2 v/n v+ ;
+
+: half-way-between-oints ( o1 o2 -- p )
+ [ location>> ] bi@ half-way ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors colors combinators float-arrays jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle strings system ;
+IN: jamshred.player
+
+TUPLE: player < oint
+ { name string }
+ { sounds sounds }
+ tunnel
+ nearest-segment
+ { last-move integer }
+ { speed float } ;
+
+! speeds are in GL units / second
+: default-speed ( -- speed ) 1.0 ;
+: max-speed ( -- speed ) 30.0 ;
+
+: <player> ( name sounds -- player )
+ [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
+ f f 0 default-speed player boa ;
+
+: turn-player ( player x-radians y-radians -- )
+ >r over r> left-pivot up-pivot ;
+
+: roll-player ( player z-radians -- )
+ forward-pivot ;
+
+: to-tunnel-start ( player -- )
+ [ tunnel>> first dup location>> ]
+ [ tuck (>>location) (>>nearest-segment) ] bi ;
+
+: play-in-tunnel ( player segments -- )
+ >>tunnel to-tunnel-start ;
+
+: update-nearest-segment ( player -- )
+ [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
+ [ (>>nearest-segment) ] tri ;
+
+: update-time ( player -- seconds-passed )
+ millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
+
+: moved ( player -- ) millis swap (>>last-move) ;
+
+: speed-range ( -- range )
+ max-speed [0,b] ;
+
+: change-player-speed ( inc player -- )
+ [ + speed-range clamp-to-range ] change-speed drop ;
+
+: multiply-player-speed ( n player -- )
+ [ * speed-range clamp-to-range ] change-speed drop ;
+
+: distance-to-move ( seconds-passed player -- distance )
+ speed>> * ;
+
+: bounce ( d-left player -- d-left' player )
+ {
+ [ dup nearest-segment>> bounce-off-wall ]
+ [ sounds>> bang ]
+ [ 3/4 swap multiply-player-speed ]
+ [ ]
+ } cleave ;
+
+:: (distance) ( heading player -- current next location heading )
+ player nearest-segment>>
+ player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
+ player location>> heading ;
+
+: distance-to-heading-segment ( heading player -- distance )
+ (distance) distance-to-next-segment ;
+
+: distance-to-heading-segment-area ( heading player -- distance )
+ (distance) distance-to-next-segment-area ;
+
+: distance-to-collision ( player -- distance )
+ dup nearest-segment>> (distance-to-collision) ;
+
+: almost-to-collision ( player -- distance )
+ distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
+
+: from ( player -- radius distance-from-centre )
+ [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
+ distance-from-centre ;
+
+: distance-from-wall ( player -- distance ) from - ;
+: fraction-from-centre ( player -- fraction ) from swap / ;
+: fraction-from-wall ( player -- fraction )
+ fraction-from-centre 1 swap - ;
+
+: update-nearest-segment2 ( heading player -- )
+ 2dup distance-to-heading-segment-area 0 <= [
+ [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
+ [ (>>nearest-segment) ] tri
+ ] [
+ 2drop
+ ] if ;
+
+:: move-player-on-heading ( d-left player distance heading -- d-left' player )
+ [let* | d-to-move [ d-left distance min ]
+ move-v [ d-to-move heading n*v ] |
+ move-v player location+
+ heading player update-nearest-segment2
+ d-left d-to-move - player ] ;
+
+: distance-to-move-freely ( player -- distance )
+ [ almost-to-collision ]
+ [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
+
+: ?move-player-freely ( d-left player -- d-left' player )
+ over 0 > [
+ ! must make sure we are moving a significant distance, otherwise
+ ! we can recurse endlessly due to floating-point imprecision.
+ ! (at least I /think/ that's what causes it...)
+ dup distance-to-move-freely dup 0.1 > [
+ over forward>> move-player-on-heading ?move-player-freely
+ ] [ drop ] if
+ ] when ;
+
+: drag-heading ( player -- heading )
+ [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
+
+: drag-player ( d-left player -- d-left' player )
+ dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
+ [ drag-heading move-player-on-heading ] bi ;
+
+: (move-player) ( d-left player -- d-left' player )
+ ?move-player-freely over 0 > [
+ ! bounce
+ drag-player
+ (move-player)
+ ] when ;
+
+: move-player ( player -- )
+ [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
+
+: update-player ( player -- )
+ [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io.files kernel openal sequences ;
+IN: jamshred.sound
+
+TUPLE: sounds bang ;
+
+: assign-sound ( source wav-path -- )
+ resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
+
+: <sounds> ( -- sounds )
+ init-openal 1 gen-sources first sounds boa
+ dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
+
+: bang ( sounds -- ) bang>> source-play check-error ;
--- /dev/null
+A simple 3d tunnel racing game
--- /dev/null
+applications
+games
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays float-arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test ;
+IN: jamshred.tunnel.tests
+
+[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
+ T{ segment f { 1 1 1 } f f f 1 }
+ T{ oint f { 0 0 0.25 } }
+ nearer-segment number>> ] unit-test
+
+[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+
+[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test
+
+[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test
+
+: test-segment-oint ( -- oint )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
+
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
+
+: simplest-straight-ahead ( -- oint segment )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
+[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
+
+: simple-collision-up ( -- oint segment )
+ { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0.0 1.0 0.0 } ] [ simple-collision-up sideways-heading ] unit-test
+[ { 0.0 0.0 0.0 } ] [ simple-collision-up sideways-relative-location ] unit-test
+[ { 0.0 1.0 0.0 } ]
+[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays colors combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
+USE: tools.walker
+IN: jamshred.tunnel
+
+: n-segments ( -- n ) 5000 ; inline
+
+TUPLE: segment < oint number color radius ;
+C: <segment> segment
+
+: segment-number++ ( segment -- )
+ [ number>> 1+ ] keep (>>number) ;
+
+: random-color ( -- color )
+ { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
+
+: tunnel-segment-distance ( -- n ) 0.4 ;
+: random-rotation-angle ( -- theta ) pi 20 / ;
+
+: random-segment ( previous-segment -- segment )
+ clone dup random-rotation-angle random-turn
+ tunnel-segment-distance over go-forward
+ random-color >>color dup segment-number++ ;
+
+: (random-segments) ( segments n -- segments )
+ dup 0 > [
+ >r dup peek random-segment over push r> 1- (random-segments)
+ ] [ drop ] if ;
+
+: default-segment-radius ( -- r ) 1 ;
+
+: initial-segment ( -- segment )
+ F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
+ 0 random-color default-segment-radius <segment> ;
+
+: random-segments ( n -- segments )
+ initial-segment 1vector swap (random-segments) ;
+
+: simple-segment ( n -- segment )
+ [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
+ random-color default-segment-radius <segment> ;
+
+: simple-segments ( n -- segments )
+ [ simple-segment ] map ;
+
+: <random-tunnel> ( -- segments )
+ n-segments random-segments ;
+
+: <straight-tunnel> ( -- segments )
+ n-segments simple-segments ;
+
+: sub-tunnel ( from to segments -- segments )
+ #! return segments between from and to, after clamping from and to to
+ #! valid values
+ [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
+
+: nearer-segment ( segment segment oint -- segment )
+ #! return whichever of the two segments is nearer to the oint
+ >r 2dup r> tuck distance >r distance r> < -rot ? ;
+
+: (find-nearest-segment) ( nearest next oint -- nearest ? )
+ #! find the nearest of 'next' and 'nearest' to 'oint', and return
+ #! t if the nearest hasn't changed
+ pick >r nearer-segment dup r> = ;
+
+: find-nearest-segment ( oint segments -- segment )
+ dup first swap rest-slice rot [ (find-nearest-segment) ] curry
+ find 2drop ;
+
+: nearest-segment-forward ( segments oint start -- segment )
+ rot dup length swap <slice> find-nearest-segment ;
+
+: nearest-segment-backward ( segments oint start -- segment )
+ swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
+
+: nearest-segment ( segments oint start-segment -- segment )
+ #! find the segment nearest to 'oint', and return it.
+ #! start looking at segment 'start-segment'
+ number>> over >r
+ [ nearest-segment-forward ] 3keep
+ nearest-segment-backward r> nearer-segment ;
+
+: get-segment ( segments n -- segment )
+ over sequence-index-range clamp-to-range swap nth ;
+
+: next-segment ( segments current-segment -- segment )
+ number>> 1+ get-segment ;
+
+: previous-segment ( segments current-segment -- segment )
+ number>> 1- get-segment ;
+
+: heading-segment ( segments current-segment heading -- segment )
+ #! the next segment on the given heading
+ over forward>> v. 0 <=> {
+ { +gt+ [ next-segment ] }
+ { +lt+ [ previous-segment ] }
+ { +eq+ [ nip ] } ! current segment
+ } case ;
+
+:: distance-to-next-segment ( current next location heading -- distance )
+ [let | cf [ current forward>> ] |
+ cf next location>> v. cf location v. - cf heading v. / ] ;
+
+:: distance-to-next-segment-area ( current next location heading -- distance )
+ [let | cf [ current forward>> ]
+ h [ next current half-way-between-oints ] |
+ cf h v. cf location v. - cf heading v. / ] ;
+
+: vector-to-centre ( seg loc -- v )
+ over location>> swap v- swap forward>> proj-perp ;
+
+: distance-from-centre ( seg loc -- distance )
+ vector-to-centre norm ;
+
+: wall-normal ( seg oint -- n )
+ location>> vector-to-centre normalize ;
+
+: distant ( -- n ) 1000 ;
+
+: max-real ( a b -- c )
+ #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
+ dup real? [
+ over real? [ max ] [ nip ] if
+ ] [
+ drop dup real? [ drop distant ] unless
+ ] if ;
+
+:: collision-coefficient ( v w r -- c )
+ v norm 0 = [
+ distant
+ ] [
+ [let* | a [ v dup v. ]
+ b [ v w v. 2 * ]
+ c [ w dup v. r sq - ] |
+ c b a quadratic max-real ]
+ ] if ;
+
+: sideways-heading ( oint segment -- v )
+ [ forward>> ] bi@ proj-perp ;
+
+: sideways-relative-location ( oint segment -- loc )
+ [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
+
+: (distance-to-collision) ( oint segment -- distance )
+ [ sideways-heading ] [ sideways-relative-location ]
+ [ nip radius>> ] 2tri collision-coefficient ;
+
+: collision-vector ( oint segment -- v )
+ dupd (distance-to-collision) swap forward>> n*v ;
+
+: bounce-forward ( segment oint -- )
+ [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
+
+: bounce-left ( segment oint -- )
+ #! must be done after forward
+ [ forward>> vneg ] dip [ left>> swap reflect ]
+ [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
+
+: bounce-up ( segment oint -- )
+ #! must be done after forward and left!
+ nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
+
+: bounce-off-wall ( oint segment -- )
+ swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
+
! 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
! 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>
{ "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-when
+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." } ;
TUPLE: spider base count max-count sleep max-depth initial-links
filters spidered todo nonmatching quiet ;
-! secure? agent page-timeout data-timeout overall-timeout
TUPLE: spider-result url depth headers fetch-time parsed-html
links processing-time timestamp ;
<PRIVATE
-: relative-url? ( url -- ? ) protocol>> not ;
-
: apply-filters ( links spider -- links' )
filters>> [ '[ _ 1&& ] filter ] when* ;
[ initial-links>> normalize-hrefs 0 ] keep
[ add-todo ] keep ;
-: slurp-heap-when ( heap quot1 quot2: ( value key -- ) -- )
+: 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-when ] [ 3drop ] if ] 3bi
+ [ roll [ slurp-heap-while ] [ 3drop ] if ] 3bi
] if ; inline recursive
PRIVATE>
'[
_ <= spider get
[ count>> ] [ max-count>> ] bi < and
- ] [ spider-page spider-sleep ] slurp-heap-when
+ ] [ spider-page spider-sleep ] slurp-heap-while
spider get
] with-variable
] with-logging ;
--- /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 / ;
<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 ;
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 [
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces make math sequences layouts
-alien.c-types alien.structs compiler.backend ;
+alien.c-types alien.structs cpu.architecture ;
IN: compiler.alien
-! Common utilities
-
: large-struct? ( ctype -- ? )
- dup c-struct? [
- heap-size struct-small-enough? not
- ] [ drop f ] if ;
+ dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
: alien-parameters ( params -- seq )
dup parameters>>
[ parameter-align drop dup , ] keep stack-size +
] reduce cell align
] { } make ;
-
-: return-size ( ctype -- n )
- #! Amount of space we reserve for a return value.
- dup large-struct? [ heap-size ] [ drop 0 ] if ;
-
-: alien-stack-frame ( params -- n )
- alien-parameters parameter-sizes drop ;
-
-: alien-invoke-frame ( params -- n )
- #! One cell is temporary storage, temp@
- dup return>> return-size
- swap alien-stack-frame +
- cell + ;
HOOK: load-indirect cpu ( obj reg -- )
-HOOK: stack-frame cpu ( frame-size -- n )
-
-: stack-frame* ( -- n )
- \ stack-frame get stack-frame ;
+HOOK: stack-frame-size cpu ( frame-size -- n )
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays
-locals layouts
+locals layouts alien.c-types alien.structs
stack-checker.inlining
compiler.intrinsics
compiler.tree
: emit-call ( word -- next )
finalize-phantoms
{
- { [ tail-call? not ] [ 0 ##frame-required ##call iterate-next ] }
+ { [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
{ [ dup loops get key? ] [ loops get at local-recursive-call ] }
[ ##epilogue ##jump stop-iterating ]
} cond ;
(write-barrier)
} [ t "intrinsic" set-word-prop ] each
-: allot-size ( #call -- n )
+: allot-size ( -- n )
1 phantom-datastack get phantom-input first value>> ;
:: emit-allot ( size type tag -- )
M: #terminate emit-node drop stop-iterating ;
! FFI
+: return-size ( ctype -- n )
+ #! Amount of space we reserve for a return value.
+ {
+ { [ dup c-struct? not ] [ drop 0 ] }
+ { [ dup large-struct? not ] [ drop 2 cells ] }
+ [ heap-size ]
+ } cond ;
+
+: <alien-stack-frame> ( params -- stack-frame )
+ stack-frame new
+ swap
+ [ return>> return-size >>return ]
+ [ alien-parameters parameter-sizes drop >>params ] bi
+ dup [ params>> ] [ return>> ] bi + >>size ;
+
+: alien-stack-frame ( node -- )
+ params>> <alien-stack-frame> ##stack-frame ;
+
+: emit-alien-node ( node quot -- next )
+ [ drop alien-stack-frame ]
+ [ [ params>> ] dip call ] 2bi
+ iterate-next ; inline
+
M: #alien-invoke emit-node
- params>>
- [ alien-invoke-frame ##frame-required ]
- [ ##alien-invoke iterate-next ]
- bi ;
+ [ ##alien-invoke ] emit-alien-node ;
M: #alien-indirect emit-node
- params>>
- [ alien-invoke-frame ##frame-required ]
- [ ##alien-indirect iterate-next ]
- bi ;
+ [ ##alien-indirect ] emit-alien-node ;
M: #alien-callback emit-node
params>> dup xt>> dup
- [ init-phantoms ##alien-callback ] with-cfg-builder
+ [
+ init-phantoms
+ [ ##alien-callback ] emit-alien-node drop
+ ] with-cfg-builder
iterate-next ;
! No-op nodes
V{ } clone >>instructions
V{ } clone >>successors ;
-TUPLE: mr instructions word label frame-size spill-counts ;
+TUPLE: mr instructions word label ;
: <mr> ( instructions word label -- mr )
mr new
INSN: ##inc-d n ;
INSN: ##inc-r n ;
-! Calling convention
-INSN: ##return ;
-
! Subroutine calls
+TUPLE: stack-frame
+{ size integer }
+{ params integer }
+{ return integer }
+{ total-size integer } ;
+
+INSN: ##stack-frame stack-frame ;
+ : ##simple-stack-frame ( -- ) T{ stack-frame } ##stack-frame ;
INSN: ##call word ;
INSN: ##jump word ;
+INSN: ##return ;
+
INSN: ##intrinsic quot defs-vregs uses-vregs ;
! Jump tables
! Instructions used by CFG IR only.
INSN: ##prologue ;
INSN: ##epilogue ;
-INSN: ##frame-required n ;
INSN: ##branch ;
INSN: ##branch-f < ##cond-branch ;
M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
! Instructions used by machine IR only.
-INSN: _prologue ;
-INSN: _epilogue ;
+INSN: _prologue stack-frame ;
+INSN: _epilogue stack-frame ;
INSN: _label id ;
SYMBOL: frame-required?
-SYMBOL: frame-size
-
SYMBOL: spill-counts
: init-stack-frame-builder ( -- )
frame-required? off
- 0 frame-size set ;
+ T{ stack-frame } clone stack-frame set ;
+
+GENERIC: compute-stack-frame* ( insn -- )
-GENERIC: compute-frame-size* ( insn -- )
+: max-stack-frame ( frame1 frame2 -- frame3 )
+ {
+ [ [ size>> ] bi@ max ]
+ [ [ params>> ] bi@ max ]
+ [ [ return>> ] bi@ max ]
+ [ [ total-size>> ] bi@ max ]
+ } cleave
+ stack-frame boa ;
-M: ##frame-required compute-frame-size*
+M: ##stack-frame compute-stack-frame*
frame-required? on
- n>> frame-size [ max ] change ;
+ stack-frame>> stack-frame [ max-stack-frame ] change ;
-M: _spill-integer compute-frame-size*
+M: _spill-integer compute-stack-frame*
drop frame-required? on ;
-M: _spill-float compute-frame-size*
+M: _spill-float compute-stack-frame*
drop frame-required? on ;
-M: insn compute-frame-size* drop ;
+M: insn compute-stack-frame* drop ;
-: compute-frame-size ( insns -- )
- [ compute-frame-size* ] each ;
+: compute-stack-frame ( insns -- )
+ [ compute-stack-frame* ] each ;
GENERIC: insert-pro/epilogues* ( insn -- )
-M: ##frame-required insert-pro/epilogues* drop ;
+M: ##stack-frame insert-pro/epilogues* drop ;
M: ##prologue insert-pro/epilogues*
- drop frame-required? get [ _prologue ] when ;
+ drop frame-required? get [ stack-frame get _prologue ] when ;
M: ##epilogue insert-pro/epilogues*
- drop frame-required? get [ _epilogue ] when ;
+ drop frame-required? get [ stack-frame get _epilogue ] when ;
M: insn insert-pro/epilogues* , ;
[
init-stack-frame-builder
[
- [ compute-frame-size ]
+ [ compute-stack-frame ]
[ insert-pro/epilogues ]
bi
] change-instructions
- frame-size get >>frame-size
] with-scope ;
finalize-contents
finalize-heights
fresh-objects get [
- empty? [ 0 ##frame-required ##gc ] unless
+ empty? [ ##simple-stack-frame ##gc ] unless
] [ delete-all ] bi ;
: init-phantoms ( -- )
: lazy-load ( specs -- seq )
[ length phantom-datastack get phantom-input ] keep
- [ drop ] [
- [
- 2dup second clobbered?
- [ first (eager-load) ] [ first (lazy-load) ] if
- ] 2map
- ] 2bi
- [ substitute-vregs ] keep ;
+ [
+ 2dup second clobbered?
+ [ first (eager-load) ] [ first (lazy-load) ] if
+ ] 2map ;
: load-inputs ( template -- assoc )
[
compiler.codegen.fixup
compiler.cfg
compiler.cfg.instructions
-compiler.cfg.registers ;
+compiler.cfg.registers
+compiler.cfg.builder ;
IN: compiler.codegen
GENERIC: generate-insn ( insn -- )
id>> lookup-label , ;
M: _prologue generate-insn
- drop %prologue ;
+ stack-frame>>
+ [ stack-frame set ]
+ [ dup size>> stack-frame-size >>total-size drop ]
+ [ total-size>> %prologue ]
+ tri ;
M: _epilogue generate-insn
- drop %epilogue ;
+ stack-frame>> total-size>> %epilogue ;
M: ##load-literal generate-insn
[ obj>> ] [ dst>> v>operand ] bi load-literal ;
#! parameters. If the C function is returning a structure,
#! the first parameter is an implicit target area pointer,
#! so we need to use a different offset.
- return>> dup large-struct?
- [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+ return>> large-struct?
+ [ %prepare-box-struct cell ] [ 0 ] if ;
: objects>registers ( params -- )
#! Generate code for unboxing a list of C types, then
: callback-unwind ( params -- n )
{
- { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+ { [ dup abi>> "stdcall" = ] [ <alien-stack-frame> size>> ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
[ drop 0 ]
} cond ;
+++ /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
+++ /dev/null
-USING: calendar io io-internals kernel math namespaces
-nonblocking-io prettyprint quotations sequences ;
-IN: libs-io
-
-: bit-set? ( m n -- ? ) [ bitand ] keep = ;
-: set-bit ( m bit -- n ) bitor ;
-: clear-bit ( m bit -- n ) bitnot bitand ;
-
: SEEK_END 2 ; inline
: EEXIST 17 ; inline
-FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ;
-: append-mode
- O_WRONLY O_APPEND O_CREAT bitor bitor ; foldable
-
-: open-append ( path -- fd )
- append-mode file-mode open dup io-error
- [ 0 SEEK_END lseek io-error ] keep ;
-
-: touch-mode
- O_WRONLY O_APPEND O_CREAT O_EXCL bitor bitor bitor ; foldable
-
-: open-touch ( path -- fd )
- touch-mode file-mode open
- [ io-error close t ]
- [ 2drop err_no EEXIST = [ err_no io-error ] unless -1 ] recover ;
-
-: <file-appender> ( path -- stream ) open-append <writer> ;
-
-FUNCTION: int unlink ( char* path ) ;
-: delete-file ( path -- )
- unlink io-error ;
-
-FUNCTION: int mkdir ( char* path, mode_t mode ) ;
-
-: (create-directory) ( path mode -- )
- mkdir io-error ;
-
-: create-directory ( path -- )
- 0 (create-directory) ;
-
-FUNCTION: int rmdir ( char* path ) ;
-
-: delete-directory ( path -- )
- rmdir io-error ;
-
-FUNCTION: int chroot ( char* path ) ;
-FUNCTION: int chdir ( char* path ) ;
-FUNCTION: int fchdir ( int fd ) ;
-
-FUNCTION: int utimes ( char* path, timeval[2] times ) ;
-FUNCTION: int futimes ( int id, timeval[2] times ) ;
-
-TYPEDEF: longlong blkcnt_t
-TYPEDEF: int blksize_t
-TYPEDEF: int dev_t
-TYPEDEF: uint ino_t
-TYPEDEF: ushort mode_t
-TYPEDEF: ushort nlink_t
-TYPEDEF: uint uid_t
-TYPEDEF: uint gid_t
-TYPEDEF: longlong quad_t
-TYPEDEF: ulong u_long
-
-FUNCTION: int stat ( char* path, stat* sb ) ;
-
-C-STRUCT: stat
- { "dev_t" "dev" } ! device inode resides on
- { "ino_t" "ino" } ! inode's number
- { "mode_t" "mode" } ! inode protection mode
- { "nlink_t" "nlink" } ! number or hard links to the file
- { "uid_t" "uid" } ! user-id of owner
- { "gid_t" "gid" } ! group-id of owner
- { "dev_t" "rdev" } ! device type, for special file inode
- { "timespec" "atime" } ! time of last access
- { "timespec" "mtime" } ! time of last data modification
- { "timespec" "ctime" } ! time of last file status change
- { "off_t" "size" } ! file size, in bytes
- { "blkcnt_t" "blocks" } ! blocks allocated for file
- { "blksize_t" "blksize" } ! optimal file sys I/O ops blocksize
- { "u_long" "flags" } ! user defined flags for file
- { "u_long" "gen" } ; ! file generation number
-
-: stat* ( path -- byte-array )
- "stat" <c-object> [ stat io-error ] keep ;
-
-: make-timeval-array ( array -- byte-array )
- [ length "timeval" <c-array> ] keep
- dup length [ over [ pick set-timeval-nth ] [ 2drop ] if ] 2each ;
-
-: (set-file-times) ( timestamp timestamp -- alien )
- [ [ timestamp>timeval ] [ f ] if* ] 2apply 2array
- make-timeval-array ;
-
-: set-file-times ( path timestamp timestamp -- )
- #! set access, write
- (set-file-times) utimes io-error ;
-
-: set-file-times* ( fd timestamp timestamp -- )
- (set-file-times) futimes io-error ;
-
-
-: set-file-access-time ( path timestamp -- )
- f set-file-times ;
-
-: set-file-write-time ( path timestamp -- )
- >r f r> set-file-times ;
-
-
-: file-write-time ( path -- timestamp )
- stat* stat-mtime timespec>timestamp ;
-
-: file-access-time ( path -- timestamp )
- stat* stat-atime timespec>timestamp ;
-
-! File type
-: S_IFMT OCT: 0170000 ; inline ! type of file
-: S_IFIFO OCT: 0010000 ; inline ! named pipe (fifo)
-: S_IFCHR OCT: 0020000 ; inline ! character special
-: S_IFDIR OCT: 0040000 ; inline ! directory
-: S_IFBLK OCT: 0060000 ; inline ! block special
-: S_IFREG OCT: 0100000 ; inline ! regular
-: S_IFLNK OCT: 0120000 ; inline ! symbolic link
-: S_IFSOCK OCT: 0140000 ; inline ! socket
-: S_IFWHT OCT: 0160000 ; inline ! whiteout
-: S_IFXATTR OCT: 0200000 ; inline ! extended attribute
-
-! File mode
-! Read, write, execute/search by owner
-: S_IRWXU OCT: 0000700 ; inline ! rwx mask owner
-: S_IRUSR OCT: 0000400 ; inline ! r owner
-: S_IWUSR OCT: 0000200 ; inline ! w owner
-: S_IXUSR OCT: 0000100 ; inline ! x owner
-! Read, write, execute/search by group
-: S_IRWXG OCT: 0000070 ; inline ! rwx mask group
-: S_IRGRP OCT: 0000040 ; inline ! r group
-: S_IWGRP OCT: 0000020 ; inline ! w group
-: S_IXGRP OCT: 0000010 ; inline ! x group
-! Read, write, execute/search by others
-: S_IRWXO OCT: 0000007 ; inline ! rwx mask other
-: S_IROTH OCT: 0000004 ; inline ! r other
-: S_IWOTH OCT: 0000002 ; inline ! w other
-: S_IXOTH OCT: 0000001 ; inline ! x other
-
-: S_ISUID OCT: 0004000 ; inline ! set user id on execution
-: S_ISGID OCT: 0002000 ; inline ! set group id on execution
-: S_ISVTX OCT: 0001000 ; inline ! sticky bit
-
-FUNCTION: uid_t getuid ;
-FUNCTION: uid_t geteuid ;
-
-FUNCTION: gid_t getgid ;
-FUNCTION: gid_t getegid ;
-
-FUNCTION: int setuid ( uid_t uid ) ;
-FUNCTION: int seteuid ( uid_t euid ) ;
-FUNCTION: int setreuid ( uid_t ruid, uid_t euid ) ;
-
-FUNCTION: int setgid ( gid_t gid ) ;
-FUNCTION: int setegid ( gid_t egid ) ;
-FUNCTION: int setregid ( gid_t rgid, gid_t egid ) ;
-
-FUNCTION: int issetugid ;
-
-FUNCTION: int chmod ( char* path, mode_t mode ) ;
-FUNCTION: int fchmod ( int fd, mode_t mode ) ;
-
-FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
-FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
-#! lchown does not follow symbolic links
-FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ;
-
-FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ;
-FUNCTION: int setgroups ( int ngroups, gid_t* gidset ) ;
-
-FUNCTION: int flock ( int fd, int operation ) ;
-! FUNCTION: int dup ( int oldd ) ;
-! FUNCTION: int dup2 ( int oldd, int newd ) ;
-
-FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
-FUNCTION: int getdtablesize ;
-
-: file-mode? ( path mask -- ? )
- >r stat* stat-mode r> bit-set? ;
-
-: user-read? ( path -- ? ) S_IRUSR file-mode? ;
-: user-write? ( path -- ? ) S_IWUSR file-mode? ;
-: user-execute? ( path -- ? ) S_IXUSR file-mode? ;
-
-: group-read? ( path -- ? ) S_IRGRP file-mode? ;
-: group-write? ( path -- ? ) S_IWGRP file-mode? ;
-: group-execute? ( path -- ? ) S_IXGRP file-mode? ;
-
-: other-read? ( path -- ? ) S_IROTH file-mode? ;
-: other-write? ( path -- ? ) S_IWOTH file-mode? ;
-: other-execute? ( path -- ? ) S_IXOTH file-mode? ;
-
-: set-uid? ( path -- ? ) S_ISUID bit-set? ;
-: set-gid? ( path -- ? ) S_ISGID bit-set? ;
-: set-sticky? ( path -- ? ) S_ISVTX bit-set? ;
-
-: chmod* ( path mask ? -- )
- >r >r dup stat* stat-mode r> r> [
- set-bit
- ] [
- clear-bit
- ] if chmod io-error ;
-
-: set-user-read ( path ? -- ) >r S_IRUSR r> chmod* ;
-: set-user-write ( path ? -- ) >r S_IWUSR r> chmod* ;
-: set-user-execute ( path ? -- ) >r S_IXUSR r> chmod* ;
-
-: set-group-read ( path ? -- ) >r S_IRGRP r> chmod* ;
-: set-group-write ( path ? -- ) >r S_IWGRP r> chmod* ;
-: set-group-execute ( path ? -- ) >r S_IXGRP r> chmod* ;
-
-: set-other-read ( path ? -- ) >r S_IROTH r> chmod* ;
-: set-other-write ( path ? -- ) >r S_IWOTH r> chmod* ;
-: set-other-execute ( path ? -- ) >r S_IXOTH r> chmod* ;
-
-: set-uid ( path ? -- ) >r S_ISUID r> chmod* ;
-: set-gid ( path ? -- ) >r S_ISGID r> chmod* ;
-: set-sticky ( path ? -- ) >r S_ISVTX r> chmod* ;
-
: mode>symbol ( mode -- ch )
S_IFMT bitand
{
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 1 }
- { deploy-compiler? t }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { deploy-name "Jamshred" }
-}
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
-IN: jamshred.game
-
-TUPLE: jamshred sounds tunnel players running quit ;
-
-: <jamshred> ( -- jamshred )
- <sounds> <random-tunnel> "Player 1" pick <player>
- 2dup swap play-in-tunnel 1array f f jamshred boa ;
-
-: jamshred-player ( jamshred -- player )
- ! TODO: support more than one player
- players>> first ;
-
-: jamshred-update ( jamshred -- )
- dup running>> [
- jamshred-player update-player
- ] [ drop ] if ;
-
-: toggle-running ( jamshred -- )
- dup running>> [
- f >>running drop
- ] [
- [ jamshred-player moved ]
- [ t >>running drop ] bi
- ] if ;
-
-: mouse-moved ( x-radians y-radians jamshred -- )
- jamshred-player -rot turn-player ;
-
-: units-per-full-roll ( -- n ) 50 ;
-
-: jamshred-roll ( jamshred n -- )
- [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
-
-: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
-
-: mouse-scroll-y ( jamshred y -- )
- neg swap jamshred-player change-player-speed ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types colors jamshred.game
-jamshred.oint jamshred.player jamshred.tunnel kernel math
-math.constants math.functions math.vectors opengl opengl.gl
-opengl.glu sequences float-arrays ;
-IN: jamshred.gl
-
-: min-vertices 6 ; inline
-: max-vertices 32 ; inline
-
-: n-vertices ( -- n ) 32 ; inline
-
-! render enough of the tunnel that it looks continuous
-: n-segments-ahead ( -- n ) 60 ; inline
-: n-segments-behind ( -- n ) 40 ; inline
-
-: wall-drawing-offset ( -- n )
- #! so that we can't see through the wall, we draw it a bit further away
- 0.15 ;
-
-: wall-drawing-radius ( segment -- r )
- radius>> wall-drawing-offset + ;
-
-: wall-up ( segment -- v )
- [ wall-drawing-radius ] [ up>> ] bi n*v ;
-
-: wall-left ( segment -- v )
- [ wall-drawing-radius ] [ left>> ] bi n*v ;
-
-: segment-vertex ( theta segment -- vertex )
- [
- [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
- ] [
- location>> v+
- ] bi ;
-
-: segment-vertex-normal ( vertex segment -- normal )
- location>> swap v- normalize ;
-
-: segment-vertex-and-normal ( segment theta -- vertex normal )
- swap [ segment-vertex ] keep dupd segment-vertex-normal ;
-
-: equally-spaced-radians ( n -- seq )
- #! return a sequence of n numbers between 0 and 2pi
- dup [ / pi 2 * * ] curry map ;
-: draw-segment-vertex ( segment theta -- )
- over segment-color gl-color segment-vertex-and-normal
- gl-normal gl-vertex ;
-
-: draw-vertex-pair ( theta next-segment segment -- )
- rot tuck draw-segment-vertex draw-segment-vertex ;
-
-: draw-segment ( next-segment segment -- )
- GL_QUAD_STRIP [
- [ draw-vertex-pair ] 2curry
- n-vertices equally-spaced-radians F{ 0.0 } append swap each
- ] do-state ;
-
-: draw-segments ( segments -- )
- 1 over length pick subseq swap [ draw-segment ] 2each ;
-
-: segments-to-render ( player -- segments )
- dup player-nearest-segment segment-number dup n-segments-behind -
- swap n-segments-ahead + rot player-tunnel sub-tunnel ;
-
-: draw-tunnel ( player -- )
- segments-to-render draw-segments ;
-
-: init-graphics ( width height -- )
- GL_DEPTH_TEST glEnable
- GL_SCISSOR_TEST glDisable
- 1.0 glClearDepth
- 0.0 0.0 0.0 0.0 glClearColor
- GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
- GL_PROJECTION glMatrixMode glLoadIdentity
- dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if
- GL_MODELVIEW glMatrixMode glLoadIdentity
- GL_LEQUAL glDepthFunc
- GL_LIGHTING glEnable
- GL_LIGHT0 glEnable
- GL_FOG glEnable
- GL_FOG_DENSITY 0.09 glFogf
- GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
- GL_COLOR_MATERIAL glEnable
- GL_LIGHT0 GL_POSITION F{ 0.0 0.0 0.0 1.0 } >c-float-array glLightfv
- GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv
- GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv
- GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ;
-
-: player-view ( player -- )
- [ location>> ]
- [ [ location>> ] [ forward>> ] bi v+ ]
- [ up>> ] tri gl-look-at ;
-
-: draw-jamshred ( jamshred width height -- )
- init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ;
-
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays calendar jamshred.game jamshred.gl
-jamshred.player jamshred.log kernel math math.constants namespaces
-sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds
-ui.gestures ui.render math.vectors math.geometry.rect ;
-IN: jamshred
-
-TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
-
-: <jamshred-gadget> ( jamshred -- gadget )
- jamshred-gadget construct-gadget swap >>jamshred ;
-
-: default-width ( -- x ) 800 ;
-: default-height ( -- y ) 600 ;
-
-M: jamshred-gadget pref-dim*
- drop default-width default-height 2array ;
-
-M: jamshred-gadget draw-gadget* ( gadget -- )
- [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
-
-: jamshred-loop ( gadget -- )
- dup jamshred>> quit>> [
- drop
- ] [
- [ jamshred>> jamshred-update ]
- [ relayout-1 ]
- [ yield jamshred-loop ] tri
- ] if ;
-
-: fullscreen ( gadget -- )
- find-world t swap set-fullscreen* ;
-
-: no-fullscreen ( gadget -- )
- find-world f swap set-fullscreen* ;
-
-: toggle-fullscreen ( world -- )
- [ fullscreen? not ] keep set-fullscreen* ;
-
-M: jamshred-gadget graft* ( gadget -- )
- [ jamshred-loop ] in-thread drop ;
-
-M: jamshred-gadget ungraft* ( gadget -- )
- jamshred>> t swap (>>quit) ;
-
-: jamshred-restart ( jamshred-gadget -- )
- <jamshred> >>jamshred drop ;
-
-: pix>radians ( n m -- theta )
- / pi 4 * * ; ! 2 / / pi 2 * * ;
-
-: x>radians ( x gadget -- theta )
- #! translate motion of x pixels to an angle
- rect-dim first pix>radians neg ;
-
-: y>radians ( y gadget -- theta )
- #! translate motion of y pixels to an angle
- rect-dim second pix>radians ;
-
-: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
- over jamshred>> >r
- [ first swap x>radians ] 2keep second swap y>radians
- r> mouse-moved ;
-
-: handle-mouse-motion ( jamshred-gadget -- )
- hand-loc get [
- over last-hand-loc>> [
- v- (handle-mouse-motion)
- ] [ 2drop ] if*
- ] 2keep >>last-hand-loc drop ;
-
-: handle-mouse-scroll ( jamshred-gadget -- )
- jamshred>> scroll-direction get
- [ first mouse-scroll-x ]
- [ second mouse-scroll-y ] 2bi ;
-
-: quit ( gadget -- )
- [ no-fullscreen ] [ close-window ] bi ;
-
-jamshred-gadget H{
- { T{ key-down f f "r" } [ jamshred-restart ] }
- { T{ key-down f f " " } [ jamshred>> toggle-running ] }
- { T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
- { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
- { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
- { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
- { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
- { T{ key-down f f "q" } [ quit ] }
- { T{ motion } [ handle-mouse-motion ] }
- { T{ mouse-scroll } [ handle-mouse-scroll ] }
-} set-gestures
-
-: jamshred-window ( -- jamshred )
- [ <jamshred> dup <jamshred-gadget> "Jamshred" open-window ] with-ui ;
-
-MAIN: jamshred-window
+++ /dev/null
-USING: kernel logging ;
-IN: jamshred.log
-
-LOG: (jamshred-log) DEBUG
-
-: with-jamshred-log ( quot -- )
- "jamshred" swap with-logging ;
-
-: jamshred-log ( message -- )
- [ (jamshred-log) ] with-jamshred-log ; ! ugly...
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: jamshred.oint tools.test ;
-IN: jamshred.oint-tests
-
-[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
-[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
-[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
-[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
-[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
-IN: jamshred.oint
-
-! An oint is a point with three linearly independent unit vectors
-! given relative to that point. In jamshred a player's location and
-! direction are given by the player's oint. Similarly, a tunnel
-! segment's location and orientation are given by an oint.
-
-TUPLE: oint location forward up left ;
-C: <oint> oint
-
-: rotation-quaternion ( theta axis -- quaternion )
- swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
-
-: rotate-vector ( q qrecip v -- v )
- v>q swap q* q* q>v ;
-
-: rotate-oint ( oint theta axis -- )
- rotation-quaternion dup qrecip pick
- [ forward>> rotate-vector >>forward ]
- [ up>> rotate-vector >>up ]
- [ left>> rotate-vector >>left ] 3tri drop ;
-
-: left-pivot ( oint theta -- )
- over left>> rotate-oint ;
-
-: up-pivot ( oint theta -- )
- over up>> rotate-oint ;
-
-: forward-pivot ( oint theta -- )
- over forward>> rotate-oint ;
-
-: random-float+- ( n -- m )
- #! find a random float between -n/2 and n/2
- dup 10000 * >fixnum random 10000 / swap 2 / - ;
-
-: random-turn ( oint theta -- )
- 2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
-
-: location+ ( v oint -- )
- [ location>> v+ ] [ (>>location) ] bi ;
-
-: go-forward ( distance oint -- )
- [ forward>> n*v ] [ location+ ] bi ;
-
-: distance-vector ( oint oint -- vector )
- [ location>> ] bi@ swap v- ;
-
-: distance ( oint oint -- distance )
- distance-vector norm ;
-
-: scalar-projection ( v1 v2 -- n )
- #! the scalar projection of v1 onto v2
- tuck v. swap norm / ;
-
-: proj-perp ( u v -- w )
- dupd proj v- ;
-
-: perpendicular-distance ( oint oint -- distance )
- tuck distance-vector swap 2dup left>> scalar-projection abs
- -rot up>> scalar-projection abs + ;
-
-:: reflect ( v n -- v' )
- #! bounce v on a surface with normal n
- v v n v. n n v. / 2 * n n*v v- ;
-
-: half-way ( p1 p2 -- p3 )
- over v- 2 v/n v+ ;
-
-: half-way-between-oints ( o1 o2 -- p )
- [ location>> ] bi@ half-way ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors combinators jamshred.log jamshred.oint
-jamshred.sound jamshred.tunnel kernel locals math math.constants
-math.order math.ranges math.vectors math.matrices shuffle
-sequences system float-arrays ;
-IN: jamshred.player
-
-TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
-
-! speeds are in GL units / second
-: default-speed ( -- speed ) 1.0 ;
-: max-speed ( -- speed ) 30.0 ;
-
-: <player> ( name sounds -- player )
- [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
- f f f default-speed player boa ;
-
-: turn-player ( player x-radians y-radians -- )
- >r over r> left-pivot up-pivot ;
-
-: roll-player ( player z-radians -- )
- forward-pivot ;
-
-: to-tunnel-start ( player -- )
- [ tunnel>> first dup location>> ]
- [ tuck (>>location) (>>nearest-segment) ] bi ;
-
-: play-in-tunnel ( player segments -- )
- >>tunnel to-tunnel-start ;
-
-: update-nearest-segment ( player -- )
- [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
- [ (>>nearest-segment) ] tri ;
-
-: update-time ( player -- seconds-passed )
- millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
-
-: moved ( player -- ) millis swap (>>last-move) ;
-
-: speed-range ( -- range )
- max-speed [0,b] ;
-
-: change-player-speed ( inc player -- )
- [ + speed-range clamp-to-range ] change-speed drop ;
-
-: multiply-player-speed ( n player -- )
- [ * speed-range clamp-to-range ] change-speed drop ;
-
-: distance-to-move ( seconds-passed player -- distance )
- speed>> * ;
-
-: bounce ( d-left player -- d-left' player )
- {
- [ dup nearest-segment>> bounce-off-wall ]
- [ sounds>> bang ]
- [ 3/4 swap multiply-player-speed ]
- [ ]
- } cleave ;
-
-:: (distance) ( heading player -- current next location heading )
- player nearest-segment>>
- player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
- player location>> heading ;
-
-: distance-to-heading-segment ( heading player -- distance )
- (distance) distance-to-next-segment ;
-
-: distance-to-heading-segment-area ( heading player -- distance )
- (distance) distance-to-next-segment-area ;
-
-: distance-to-collision ( player -- distance )
- dup nearest-segment>> (distance-to-collision) ;
-
-: from ( player -- radius distance-from-centre )
- [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
- distance-from-centre ;
-
-: distance-from-wall ( player -- distance ) from - ;
-: fraction-from-centre ( player -- fraction ) from swap / ;
-: fraction-from-wall ( player -- fraction )
- fraction-from-centre 1 swap - ;
-
-: update-nearest-segment2 ( heading player -- )
- 2dup distance-to-heading-segment-area 0 <= [
- [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
- [ (>>nearest-segment) ] tri
- ] [
- 2drop
- ] if ;
-
-:: move-player-on-heading ( d-left player distance heading -- d-left' player )
- [let* | d-to-move [ d-left distance min ]
- move-v [ d-to-move heading n*v ] |
- move-v player location+
- heading player update-nearest-segment2
- d-left d-to-move - player ] ;
-
-: move-toward-wall ( d-left player d-to-wall -- d-left' player )
- over [ forward>> ] keep distance-to-heading-segment-area min
- over forward>> move-player-on-heading ;
-
-: ?move-player-freely ( d-left player -- d-left' player )
- over 0 > [
- dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2
- move-toward-wall ?move-player-freely
- ] [ drop ] if
- ] when ;
-
-: drag-heading ( player -- heading )
- [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
-
-: drag-player ( d-left player -- d-left' player )
- dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
- [ drag-heading move-player-on-heading ] bi ;
-
-: (move-player) ( d-left player -- d-left' player )
- ?move-player-freely over 0 > [
- ! bounce
- drag-player
- (move-player)
- ] when ;
-
-: move-player ( player -- )
- [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
-
-: update-player ( player -- )
- [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;
+++ /dev/null
-USING: accessors io.files kernel openal sequences ;
-IN: jamshred.sound
-
-TUPLE: sounds bang ;
-
-: assign-sound ( source wav-path -- )
- resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
-
-: <sounds> ( -- sounds )
- init-openal 1 gen-sources first sounds boa
- dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
-
-: bang ( sounds -- ) bang>> source-play check-error ;
+++ /dev/null
-A simple 3d tunnel racing game
+++ /dev/null
-applications
-games
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test float-arrays ;
-IN: jamshred.tunnel.tests
-
-[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
- T{ segment f { 1 1 1 } f f f 1 }
- T{ oint f { 0 0 0.25 } }
- nearer-segment segment-number ] unit-test
-
-[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
-[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
-[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
-
-[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test
-
-[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test
-
-: test-segment-oint ( -- oint )
- { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
-
-[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
-[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
-[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
-[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
-[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
-[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
-[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
-[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
-
-: simplest-straight-ahead ( -- oint segment )
- { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
- initial-segment ;
-
-[ { 0 0 0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
-[ { 0 0 0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
-
-: simple-collision-up ( -- oint segment )
- { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
- initial-segment ;
-
-[ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test
-[ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test
-[ { 0 1 0 } ]
-[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
-USE: tools.walker
-IN: jamshred.tunnel
-
-: n-segments ( -- n ) 5000 ; inline
-
-TUPLE: segment < oint number color radius ;
-C: <segment> segment
-
-: segment-number++ ( segment -- )
- [ number>> 1+ ] keep (>>number) ;
-
-: random-color ( -- color )
- { 100 100 100 } [ random 100 / >float ] map { 1.0 } append ;
-
-: tunnel-segment-distance ( -- n ) 0.4 ;
-: random-rotation-angle ( -- theta ) pi 20 / ;
-
-: random-segment ( previous-segment -- segment )
- clone dup random-rotation-angle random-turn
- tunnel-segment-distance over go-forward
- random-color over set-segment-color dup segment-number++ ;
-
-: (random-segments) ( segments n -- segments )
- dup 0 > [
- >r dup peek random-segment over push r> 1- (random-segments)
- ] [ drop ] if ;
-
-: default-segment-radius ( -- r ) 1 ;
-
-: initial-segment ( -- segment )
- F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
- 0 random-color default-segment-radius <segment> ;
-
-: random-segments ( n -- segments )
- initial-segment 1vector swap (random-segments) ;
-
-: simple-segment ( n -- segment )
- [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
- random-color default-segment-radius <segment> ;
-
-: simple-segments ( n -- segments )
- [ simple-segment ] map ;
-
-: <random-tunnel> ( -- segments )
- n-segments random-segments ;
-
-: <straight-tunnel> ( -- segments )
- n-segments simple-segments ;
-
-: sub-tunnel ( from to segments -- segments )
- #! return segments between from and to, after clamping from and to to
- #! valid values
- [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
-
-: nearer-segment ( segment segment oint -- segment )
- #! return whichever of the two segments is nearer to the oint
- >r 2dup r> tuck distance >r distance r> < -rot ? ;
-
-: (find-nearest-segment) ( nearest next oint -- nearest ? )
- #! find the nearest of 'next' and 'nearest' to 'oint', and return
- #! t if the nearest hasn't changed
- pick >r nearer-segment dup r> = ;
-
-: find-nearest-segment ( oint segments -- segment )
- dup first swap rest-slice rot [ (find-nearest-segment) ] curry
- find 2drop ;
-
-: nearest-segment-forward ( segments oint start -- segment )
- rot dup length swap <slice> find-nearest-segment ;
-
-: nearest-segment-backward ( segments oint start -- segment )
- swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
-
-: nearest-segment ( segments oint start-segment -- segment )
- #! find the segment nearest to 'oint', and return it.
- #! start looking at segment 'start-segment'
- segment-number over >r
- [ nearest-segment-forward ] 3keep
- nearest-segment-backward r> nearer-segment ;
-
-: get-segment ( segments n -- segment )
- over sequence-index-range clamp-to-range swap nth ;
-
-: next-segment ( segments current-segment -- segment )
- number>> 1+ get-segment ;
-
-: previous-segment ( segments current-segment -- segment )
- number>> 1- get-segment ;
-
-: heading-segment ( segments current-segment heading -- segment )
- #! the next segment on the given heading
- over forward>> v. 0 <=> {
- { +gt+ [ next-segment ] }
- { +lt+ [ previous-segment ] }
- { +eq+ [ nip ] } ! current segment
- } case ;
-
-:: distance-to-next-segment ( current next location heading -- distance )
- [let | cf [ current forward>> ] |
- cf next location>> v. cf location v. - cf heading v. / ] ;
-
-:: distance-to-next-segment-area ( current next location heading -- distance )
- [let | cf [ current forward>> ]
- h [ next current half-way-between-oints ] |
- cf h v. cf location v. - cf heading v. / ] ;
-
-: vector-to-centre ( seg loc -- v )
- over location>> swap v- swap forward>> proj-perp ;
-
-: distance-from-centre ( seg loc -- distance )
- vector-to-centre norm ;
-
-: wall-normal ( seg oint -- n )
- location>> vector-to-centre normalize ;
-
-: distant ( -- n ) 1000 ;
-
-: max-real ( a b -- c )
- #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
- dup real? [
- over real? [ max ] [ nip ] if
- ] [
- drop dup real? [ drop distant ] unless
- ] if ;
-
-:: collision-coefficient ( v w r -- c )
- v norm 0 = [
- distant
- ] [
- [let* | a [ v dup v. ]
- b [ v w v. 2 * ]
- c [ w dup v. r sq - ] |
- c b a quadratic max-real ]
- ] if ;
-
-: sideways-heading ( oint segment -- v )
- [ forward>> ] bi@ proj-perp ;
-
-: sideways-relative-location ( oint segment -- loc )
- [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
-
-: (distance-to-collision) ( oint segment -- distance )
- [ sideways-heading ] [ sideways-relative-location ]
- [ nip radius>> ] 2tri collision-coefficient ;
-
-: collision-vector ( oint segment -- v )
- dupd (distance-to-collision) swap forward>> n*v ;
-
-: bounce-forward ( segment oint -- )
- [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
-
-: bounce-left ( segment oint -- )
- #! must be done after forward
- [ forward>> vneg ] dip [ left>> swap reflect ]
- [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
-
-: bounce-up ( segment oint -- )
- #! must be done after forward and left!
- nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
-
-: bounce-off-wall ( oint segment -- )
- swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
-
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
-~
void factorbug(void)
{
+ if(fep_disabled)
+ {
+ printf("Low level debugger disabled\n");
+ exit(1);
+ }
+
open_console();
printf("Starting low level debugger...\n");
dump stacks. This is useful for builder and
other cases where Factor is run with stdin
redirected to /dev/null */
+ fep_disabled = true;
+
print_datastack();
print_retainstack();
print_callstack();
void factorbug(void);
void dump_zone(F_ZONE *z);
+bool fep_disabled;
+
DECLARE_PRIMITIVE(die);
crash. */
else
{
- fprintf(stderr,"You have triggered a bug in Factor. Please report.\n");
- fprintf(stderr,"early_error: ");
+ printf("You have triggered a bug in Factor. Please report.\n");
+ printf("early_error: ");
print_obj(error);
- fprintf(stderr,"\n");
+ printf("\n");
factorbug();
}
}
projects / factor.git / commitdiff