Merge branch 'master' of factorcode.org:/git/factor
Joe Groff
commit
e829dcf125
|
|
@ -29,6 +29,12 @@ os unix? [
|
|||
|
||||
[ T{ inet f "google.com" 80 } ] [ "google.com" 80 with-port ] unit-test
|
||||
|
||||
! Test bad hostnames
|
||||
[ "google.com" f <inet4> ] must-fail
|
||||
[ "a.b.c.d" f <inet4> ] must-fail
|
||||
[ "google.com" f <inet6> ] must-fail
|
||||
[ "a.b.c.d" f <inet6> ] must-fail
|
||||
|
||||
! Test present on addrspecs
|
||||
[ "4.4.4.4:12" ] [ "4.4.4.4" 12 <inet4> present ] unit-test
|
||||
[ "::1:12" ] [ "::1" 12 <inet6> present ] unit-test
|
||||
|
|
|
|||
|
|
@ -68,27 +68,32 @@ SLOT: port
|
|||
|
||||
TUPLE: ipv4 { host ?string read-only } ;
|
||||
|
||||
C: <ipv4> ipv4
|
||||
|
||||
M: ipv4 inet-ntop ( data addrspec -- str )
|
||||
drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
ERROR: invalid-ipv4 string reason ;
|
||||
|
||||
M: invalid-ipv4 summary drop "Invalid IPv4 address" ;
|
||||
|
||||
ERROR: malformed-ipv4 sequence ;
|
||||
|
||||
ERROR: bad-ipv4-component string ;
|
||||
|
||||
: parse-ipv4 ( string -- seq )
|
||||
"." split dup length 4 = [ malformed-ipv4 ] unless
|
||||
[ dup string>number [ ] [ bad-ipv4-component ] ?if ] B{ } map-as ;
|
||||
[ f ] [
|
||||
"." split dup length 4 = [ malformed-ipv4 ] unless
|
||||
[ dup string>number [ ] [ bad-ipv4-component ] ?if ] B{ } map-as
|
||||
] if-empty ;
|
||||
|
||||
ERROR: invalid-ipv4 string reason ;
|
||||
|
||||
M: invalid-ipv4 summary drop "Invalid IPv4 address" ;
|
||||
: check-ipv4 ( string -- )
|
||||
[ parse-ipv4 drop ] [ invalid-ipv4 ] recover ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <ipv4> ( host -- ipv4 ) dup check-ipv4 ipv4 boa ;
|
||||
|
||||
M: ipv4 inet-ntop ( data addrspec -- str )
|
||||
drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
|
||||
|
||||
M: ipv4 inet-pton ( str addrspec -- data )
|
||||
drop [ parse-ipv4 ] [ invalid-ipv4 ] recover ;
|
||||
|
||||
|
|
@ -113,7 +118,8 @@ M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
|
|||
|
||||
TUPLE: inet4 < ipv4 { port integer read-only } ;
|
||||
|
||||
C: <inet4> inet4
|
||||
: <inet4> ( host port -- inet4 )
|
||||
over check-ipv4 inet4 boa ;
|
||||
|
||||
M: ipv4 with-port [ host>> ] dip <inet4> ;
|
||||
|
||||
|
|
@ -129,15 +135,12 @@ TUPLE: ipv6
|
|||
{ host ?string read-only }
|
||||
{ scope-id integer read-only } ;
|
||||
|
||||
: <ipv6> ( host -- ipv6 ) 0 ipv6 boa ;
|
||||
|
||||
M: ipv6 inet-ntop ( data addrspec -- str )
|
||||
drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
|
||||
|
||||
ERROR: invalid-ipv6 string reason ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
ERROR: invalid-ipv6 host reason ;
|
||||
|
||||
M: invalid-ipv6 summary drop "Invalid IPv6 address" ;
|
||||
|
||||
ERROR: bad-ipv6-component obj ;
|
||||
|
||||
ERROR: bad-ipv4-embedded-prefix obj ;
|
||||
|
|
@ -157,6 +160,18 @@ ERROR: more-than-8-components ;
|
|||
] if
|
||||
] if-empty ;
|
||||
|
||||
: check-ipv6 ( string -- )
|
||||
[ "::" split1 [ parse-ipv6 ] bi@ 2drop ] [ invalid-ipv6 ] recover ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <ipv6> ( host -- ipv6 ) dup check-ipv6 0 ipv6 boa ;
|
||||
|
||||
M: ipv6 inet-ntop ( data addrspec -- str )
|
||||
drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: pad-ipv6 ( string1 string2 -- seq )
|
||||
2dup [ length ] bi@ + 8 swap -
|
||||
dup 0 < [ more-than-8-components ] when
|
||||
|
|
@ -200,7 +215,8 @@ M: ipv6 present
|
|||
|
||||
TUPLE: inet6 < ipv6 { port integer read-only } ;
|
||||
|
||||
: <inet6> ( host port -- inet6 ) [ 0 ] dip inet6 boa ;
|
||||
: <inet6> ( host port -- inet6 )
|
||||
[ dup check-ipv6 0 ] dip inet6 boa ;
|
||||
|
||||
M: ipv6 with-port
|
||||
[ [ host>> ] [ scope-id>> ] bi ] dip
|
||||
|
|
|
|||
|
|
@ -0,0 +1,35 @@
|
|||
! Copyright (C) 2010 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: arrays ascii assocs fry io.encodings.ascii io.files
|
||||
kernel math math.order memoize sequences sorting ;
|
||||
|
||||
IN: anagrams
|
||||
|
||||
: (all-anagrams) ( seq assoc -- )
|
||||
'[ dup natural-sort _ push-at ] each ;
|
||||
|
||||
: all-anagrams ( seq -- assoc )
|
||||
H{ } clone [ (all-anagrams) ] keep
|
||||
[ nip length 1 > ] assoc-filter ;
|
||||
|
||||
MEMO: dict-words ( -- seq )
|
||||
"/usr/share/dict/words" ascii file-lines [ >lower ] map ;
|
||||
|
||||
MEMO: dict-anagrams ( -- assoc )
|
||||
dict-words all-anagrams ;
|
||||
|
||||
: anagrams ( str -- seq/f )
|
||||
>lower natural-sort dict-anagrams at ;
|
||||
|
||||
: longest ( seq -- subseq )
|
||||
dup 0 [ length max ] reduce '[ length _ = ] filter ;
|
||||
|
||||
: most-anagrams ( -- seq )
|
||||
dict-anagrams values longest ;
|
||||
|
||||
: longest-anagrams ( -- seq )
|
||||
dict-anagrams [ keys longest ] keep '[ _ at ] map ;
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1 @@
|
|||
unix
|
||||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
|
||||
USING: alien.c-types classes.struct.packed tools.test words ;
|
||||
|
||||
IN: classes.struct.packed
|
||||
|
||||
PACKED-STRUCT: abcd
|
||||
{ a int }
|
||||
{ b int }
|
||||
{ c int }
|
||||
{ d int }
|
||||
{ e short }
|
||||
{ f int }
|
||||
{ g int }
|
||||
{ h int }
|
||||
;
|
||||
|
||||
[ 30 ] [ \ abcd "struct-size" word-prop ] unit-test
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (C) 2011 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: accessors alien.c-types classes.struct
|
||||
classes.struct.private kernel locals math sequences slots
|
||||
words ;
|
||||
|
||||
IN: classes.struct.packed
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: ALIGNMENT 1
|
||||
|
||||
GENERIC: compute-packed-offset ( offset class -- offset' )
|
||||
|
||||
M: struct-slot-spec compute-packed-offset
|
||||
[ ALIGNMENT 8 * align ] dip
|
||||
[ [ 8 /i ] dip offset<< ] [ type>> heap-size 8 * + ] 2bi ;
|
||||
|
||||
M: struct-bit-slot-spec compute-packed-offset
|
||||
[ offset<< ] [ bits>> + ] 2bi ;
|
||||
|
||||
: compute-packed-offsets ( slots -- size )
|
||||
0 [ compute-packed-offset ] reduce 8 align 8 /i ;
|
||||
|
||||
:: (define-packed-class) ( class slots offsets-quot -- )
|
||||
slots empty? [ struct-must-have-slots ] when
|
||||
class redefine-struct-tuple-class
|
||||
slots make-slots dup check-struct-slots :> slot-specs
|
||||
slot-specs offsets-quot call :> unaligned-size
|
||||
ALIGNMENT :> alignment
|
||||
unaligned-size :> size
|
||||
|
||||
class slot-specs size alignment c-type-for-class :> c-type
|
||||
|
||||
c-type class typedef
|
||||
class slot-specs define-accessors
|
||||
class size "struct-size" set-word-prop
|
||||
class dup make-struct-prototype "prototype" set-word-prop
|
||||
class (struct-methods) ; inline
|
||||
|
||||
: define-packed-struct-class ( class slots -- )
|
||||
[ compute-packed-offsets ] (define-packed-class) ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SYNTAX: PACKED-STRUCT:
|
||||
parse-struct-definition define-packed-struct-class ;
|
||||
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Support for packed structures
|
||||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1,251 @@
|
|||
! Copyright (C) 2010 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: accessors combinators combinators.short-circuit
|
||||
continuations formatting fry io kernel math math.functions
|
||||
math.order math.parser math.ranges random sequences strings ;
|
||||
|
||||
IN: hamurabi
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: game year population births deaths stores harvest yield
|
||||
plague acres eaten cost feed planted birth-factor rat-factor
|
||||
total-births total-deaths ;
|
||||
|
||||
: <game> ( -- game )
|
||||
game new
|
||||
0 >>year
|
||||
95 >>population
|
||||
5 >>births
|
||||
0 >>deaths
|
||||
2800 >>stores
|
||||
3000 >>harvest
|
||||
3 >>yield
|
||||
f >>plague
|
||||
0 >>cost
|
||||
dup births>> >>total-births
|
||||
dup deaths>> >>total-deaths
|
||||
dup births>> '[ _ + ] change-population
|
||||
dup [ harvest>> ] [ yield>> ] bi / >>acres
|
||||
dup [ harvest>> ] [ stores>> ] bi - >>eaten ;
|
||||
|
||||
: #acres-available ( game -- n )
|
||||
[ stores>> ] [ cost>> ] bi /i ;
|
||||
|
||||
: #acres-per-person ( game -- n )
|
||||
[ acres>> ] [ population>> ] bi / ;
|
||||
|
||||
: #harvested ( game -- n )
|
||||
[ planted>> ] [ yield>> ] bi * ;
|
||||
|
||||
: #eaten ( game -- n )
|
||||
dup rat-factor>> odd?
|
||||
[ [ stores>> ] [ rat-factor>> ] bi / ] [ drop 0 ] if ;
|
||||
|
||||
: #stored ( game -- n )
|
||||
[ harvest>> ] [ eaten>> ] bi - ;
|
||||
|
||||
: #percent-died ( game -- n )
|
||||
[ total-deaths>> 100 * ] [ total-births>> ] [ year>> ] tri / / ;
|
||||
|
||||
: #births ( game -- n )
|
||||
{
|
||||
[ acres>> 20 * ]
|
||||
[ stores>> + ]
|
||||
[ birth-factor>> * ]
|
||||
[ population>> / ]
|
||||
} cleave 100 /i 1 + ;
|
||||
|
||||
: #starved ( game -- n )
|
||||
[ population>> ] [ feed>> 20 /i ] bi - 0 max ;
|
||||
|
||||
: leave-fink ( -- )
|
||||
"DUE TO THIS EXTREME MISMANAGEMENT YOU HAVE NOT ONLY" print
|
||||
"BEEN IMPEACHED AND THROWN OUT OF OFFICE BUT YOU HAVE" print
|
||||
"ALSO BEEN DECLARED 'NATIONAL FINK' !!" print ;
|
||||
|
||||
: leave-starved ( game -- game )
|
||||
dup deaths>> "YOU STARVED %d PEOPLE IN ONE YEAR!!!\n" printf
|
||||
leave-fink "exit" throw ;
|
||||
|
||||
: leave-nero ( -- )
|
||||
"YOUR HEAVY-HANDED PERFORMANCE SMACKS OF NERO AND IVAN IV." print
|
||||
"THE PEOPLE (REMAINING) FIND YOU AN UNPLEASANT RULER, AND" print
|
||||
"FRANKLY, HATE YOUR GUTS!" print ;
|
||||
|
||||
: leave-not-too-bad ( game -- game )
|
||||
"YOUR PERFORMANCE COULD HAVE BEEN SOMEWHAT BETTER, BUT" print
|
||||
"REALLY WASN'T TOO BAD AT ALL." print
|
||||
dup population>> 4/5 * floor [0,b] random
|
||||
"%d PEOPLE WOULD DEARLY LIKE TO SEE YOU ASSASSINATED\n" printf
|
||||
"BUT WE ALL HAVE OUR TRIVIAL PROBLEMS" print ;
|
||||
|
||||
: leave-best ( -- )
|
||||
"A FANTASTIC PERFORMANCE!!! CHARLEMANGE, DISRAELI, AND" print
|
||||
"JEFFERSON COMBINED COULD NOT HAVE DONE BETTER!" print ;
|
||||
|
||||
: leave ( game -- )
|
||||
dup [ #percent-died ] [ #acres-per-person ] bi
|
||||
{
|
||||
{ [ 2dup [ 33 > ] [ 7 < ] bi* or ] [ leave-fink ] }
|
||||
{ [ 2dup [ 10 > ] [ 9 < ] bi* or ] [ leave-nero ] }
|
||||
{ [ 2dup [ 3 > ] [ 10 < ] bi* or ] [ leave-not-too-bad ] }
|
||||
[ leave-best ]
|
||||
} cond 3drop ;
|
||||
|
||||
: check-number ( n -- )
|
||||
{ [ f eq? ] [ 0 < ] [ fixnum? not ] } 1|| [
|
||||
"HAMURABI: I CANNOT DO WHAT YOU WISH." print
|
||||
"GET YOURSELF ANOTHER STEWARD!!!!!" print
|
||||
"exit" throw
|
||||
] when ;
|
||||
|
||||
: input ( prompt -- n/f )
|
||||
write flush readln string>number [ check-number ] keep ;
|
||||
|
||||
: bad-stores ( game -- )
|
||||
stores>>
|
||||
"HAMURABI: THINK AGAIN. YOU HAVE ONLY" print
|
||||
"%d BUSHELS OF STORES. NOW THEN," printf nl ;
|
||||
|
||||
: bad-acres ( game -- )
|
||||
acres>>
|
||||
"HAMURABI: THINK AGAIN. YOU ONLY OWN %d ACRES. NOW THEN,"
|
||||
printf nl ;
|
||||
|
||||
: bad-population ( game -- )
|
||||
population>>
|
||||
"BUT YOU HAVE ONLY %d PEOPLE TO TEND THE FIELDS. NOW THEN,"
|
||||
printf nl ;
|
||||
|
||||
: check-error ( game n error -- game n ? )
|
||||
{
|
||||
{ "acres" [ over bad-acres t ] }
|
||||
{ "stores" [ over bad-stores t ] }
|
||||
{ "population" [ over bad-population t ] }
|
||||
[ drop f ]
|
||||
} case ;
|
||||
|
||||
: adjust-acres ( game n -- game )
|
||||
[ '[ _ + ] change-acres ]
|
||||
[ over cost>> * '[ _ - ] change-stores ] bi ;
|
||||
|
||||
: buy-acres ( game -- game )
|
||||
"HOW MANY ACRES DO YOU WISH TO BUY? " input
|
||||
over #acres-available dupd > "stores" and check-error
|
||||
[ drop buy-acres ] [ adjust-acres ] if ;
|
||||
|
||||
: sell-acres ( game -- game )
|
||||
"HOW MANY ACRES DO YOU WISH TO SELL? " input
|
||||
over acres>> dupd >= "acres" and check-error
|
||||
[ drop sell-acres ] [ neg adjust-acres ] if nl ;
|
||||
|
||||
: trade-land ( game -- game )
|
||||
dup cost>> "LAND IS TRADING AT %d BUSHELS PER ACRE.\n" printf
|
||||
buy-acres sell-acres ;
|
||||
|
||||
: feed-people ( game -- game )
|
||||
"HOW MANY BUSHELS DO YOU WISH TO FEED YOUR PEOPLE? " input
|
||||
over stores>> dupd > "stores" and check-error
|
||||
[ drop feed-people ] [
|
||||
[ >>feed ] [ '[ _ - ] change-stores ] bi
|
||||
] if nl ;
|
||||
|
||||
: plant-seeds ( game -- game )
|
||||
"HOW MANY ACRES DO YOU WISH TO PLANT WITH SEED? " input {
|
||||
{ [ over acres>> dupd > ] [ "acres" ] }
|
||||
{ [ over stores>> 2 * dupd > ] [ "stores" ] }
|
||||
{ [ over population>> 10 * dupd > ] [ "population" ] }
|
||||
[ f ]
|
||||
} cond check-error [ drop plant-seeds ] [
|
||||
[ >>planted ] [ 2/ '[ _ - ] change-stores ] bi
|
||||
] if nl ;
|
||||
|
||||
: report-status ( game -- game )
|
||||
"HAMURABI: I BEG TO REPORT TO YOU," print
|
||||
dup [ year>> ] [ deaths>> ] [ births>> ] tri
|
||||
"IN YEAR %d, %d PEOPLE STARVED, %d CAME TO THE CITY\n" printf
|
||||
dup plague>> [
|
||||
"A HORRIBLE PLAGUE STRUCK! HALF THE PEOPLE DIED." print
|
||||
] when
|
||||
dup population>> "POPULATION IS NOW %d.\n" printf
|
||||
dup acres>> "THE CITY NOW OWNS %d ACRES.\n" printf
|
||||
dup yield>> "YOU HARVESTED %d BUSHELS PER ACRE.\n" printf
|
||||
dup eaten>> "RATS ATE %d BUSHELS.\n" printf
|
||||
dup stores>> "YOU NOW HAVE %d BUSHELS IN STORE.\n\n" printf ;
|
||||
|
||||
: update-randomness ( game -- game )
|
||||
17 26 [a,b] random >>cost
|
||||
5 [1,b] random >>yield
|
||||
5 [1,b] random >>birth-factor
|
||||
5 [1,b] random >>rat-factor
|
||||
100 random 15 < >>plague ;
|
||||
|
||||
: update-stores ( game -- game )
|
||||
dup #harvested >>harvest
|
||||
dup #eaten >>eaten
|
||||
dup #stored '[ _ + ] change-stores ;
|
||||
|
||||
: update-births ( game -- game )
|
||||
dup #births
|
||||
[ >>births ]
|
||||
[ '[ _ + ] change-total-births ]
|
||||
[ '[ _ + ] change-population ] tri ;
|
||||
|
||||
: update-deaths ( game -- game )
|
||||
dup #starved
|
||||
[ >>deaths ]
|
||||
[ '[ _ + ] change-total-deaths ]
|
||||
[ '[ _ - ] change-population ] tri ;
|
||||
|
||||
: check-plague ( game -- game )
|
||||
dup plague>> [ [ 2/ ] change-population ] when ;
|
||||
|
||||
: check-starvation ( game -- game )
|
||||
dup [ deaths>> ] [ population>> 0.45 * ] bi >
|
||||
[ leave-starved ] when ;
|
||||
|
||||
: year ( game -- game )
|
||||
[ 1 + ] change-year
|
||||
report-status
|
||||
update-randomness
|
||||
trade-land
|
||||
feed-people
|
||||
plant-seeds
|
||||
update-stores
|
||||
update-births
|
||||
update-deaths
|
||||
check-plague
|
||||
check-starvation ;
|
||||
|
||||
: spaces ( n -- )
|
||||
CHAR: \s <string> write ;
|
||||
|
||||
: welcome ( -- )
|
||||
32 spaces "HAMURABI" print
|
||||
15 spaces "CREATIVE COMPUTING MORRISTOWN, NEW JERSEY" print
|
||||
nl nl nl
|
||||
"TRY YOUR HAND AT GOVERNING ANCIENT SUMERIA" print
|
||||
"SUCCESSFULLY FOR A TEN-YEAR TERM OF OFFICE" print nl ;
|
||||
|
||||
: finish ( game -- )
|
||||
dup #percent-died
|
||||
"IN YOUR 10-YEAR TERM OF OFFICE, %d PERCENT OF THE\n" printf
|
||||
"POPULATION STARVED PER YEAR ON AVERAGE, I.E., A TOTAL OF" print
|
||||
dup total-deaths>> "%d PEOPLE DIED!!\n" printf
|
||||
"YOU STARTED WITH 10 ACRES PER PERSON AND ENDED WITH" print
|
||||
dup #acres-per-person "%d ACRES PER PERSON\n" printf
|
||||
nl leave nl "SO LONG FOR NOW." print ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! FIXME: "exit" throw is used to break early, perhaps use bool?
|
||||
|
||||
: hamurabi ( -- )
|
||||
welcome <game> [
|
||||
10 [ year ] times finish
|
||||
] [ 2drop ] recover ;
|
||||
|
||||
MAIN: hamurabi
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Port of the HAMURABI.BAS game
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (C) 2010 John Benediktsson.
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: help.markup help.syntax math math.approx ;
|
||||
|
||||
IN: math.approx
|
||||
|
||||
HELP: approximate
|
||||
{ $values { "x" ratio } { "epsilon" ratio } { "y" ratio } }
|
||||
{ $description
|
||||
"Applied to two fractional numbers \"x\" and \"epsilon\", returns the "
|
||||
"simplest rational number within \"epsilon\" of \"x\"."
|
||||
$nl
|
||||
"A rational number \"y\" is said to be simpler than another \"y'\" if "
|
||||
"abs numerator y <= abs numerator y', and denominator y <= demoniator y'"
|
||||
$nl
|
||||
"Any real interval contains a unique simplest rational; in particular note "
|
||||
"that 0/1 is the simplest rational of all."
|
||||
} ;
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2010 John Benediktsson.
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: kernel math math.approx math.constants
|
||||
math.floating-point sequences tools.test ;
|
||||
|
||||
IN: math.approx.tests
|
||||
|
||||
[ { 3 3 13/4 16/5 19/6 22/7 } ]
|
||||
[
|
||||
pi double>ratio
|
||||
{ 1/2 1/4 1/8 1/16 1/32 1/64 }
|
||||
[ approximate ] with map
|
||||
] unit-test
|
||||
|
||||
[ { -3 -3 -13/4 -16/5 -19/6 -22/7 } ]
|
||||
[
|
||||
pi double>ratio neg
|
||||
{ 1/2 1/4 1/8 1/16 1/32 1/64 }
|
||||
[ approximate ] with map
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
! Copyright (C) 2010 John Benediktsson.
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: combinators kernel locals math math.functions ;
|
||||
|
||||
IN: math.approx
|
||||
|
||||
<PRIVATE
|
||||
|
||||
:: (simplest) ( n d n' d' -- val ) ! assumes 0 < n/d < n'/d'
|
||||
n d /mod :> ( q r )
|
||||
n' d' /mod :> ( q' r' )
|
||||
{
|
||||
{ [ r zero? ] [ q ] }
|
||||
{ [ q q' = not ] [ q 1 + ] }
|
||||
[
|
||||
d' r' d r (simplest) >fraction :> ( n'' d'' )
|
||||
q n'' * d'' + n'' /
|
||||
]
|
||||
} cond ;
|
||||
|
||||
:: simplest ( x y -- val )
|
||||
{
|
||||
{ [ x y > ] [ y x simplest ] }
|
||||
{ [ x y = ] [ x ] }
|
||||
{ [ x 0 > ] [ x y [ >fraction ] bi@ (simplest) ] }
|
||||
{ [ y 0 < ] [ y x [ neg >fraction ] bi@ (simplest) neg ] }
|
||||
[ 0 ]
|
||||
} cond ;
|
||||
|
||||
: check-float ( x -- x )
|
||||
dup float? [ "can't be floats" throw ] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: approximate ( x epsilon -- y )
|
||||
[ check-float ] bi@ [ - ] [ + ] 2bi simplest ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1 @@
|
|||
Approximating rational numbers.
|
||||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1,122 @@
|
|||
! Copyright (C) 2010 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: help.syntax help.markup io.sockets math memcached
|
||||
quotations sequences strings ;
|
||||
|
||||
IN: memcached
|
||||
|
||||
HELP: memcached-server
|
||||
{ $var-description
|
||||
"Holds an " { $link inet } " object with the address of "
|
||||
"an Memcached server."
|
||||
} ;
|
||||
|
||||
HELP: with-memcached
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description
|
||||
"Opens a network connection to the " { $link memcached-server }
|
||||
" and runs the specified quotation."
|
||||
} ;
|
||||
|
||||
HELP: m/get
|
||||
{ $values { "key" string } { "val" string } }
|
||||
{ $description
|
||||
"Gets a single key."
|
||||
} ;
|
||||
|
||||
HELP: m/set
|
||||
{ $values { "val" string } { "key" string } }
|
||||
{ $description
|
||||
"Sets a single key to a particular value, whether the item "
|
||||
"exists or not."
|
||||
} ;
|
||||
|
||||
HELP: m/add
|
||||
{ $values { "val" string } { "key" string } }
|
||||
{ $description
|
||||
"Adds an item only if the item does not already exist. "
|
||||
"If the item already exists, throws an error."
|
||||
} ;
|
||||
|
||||
HELP: m/replace
|
||||
{ $values { "val" string } { "key" string } }
|
||||
{ $description
|
||||
"Replaces an item only if it already eixsts. "
|
||||
"If the item does not exist, throws an error."
|
||||
} ;
|
||||
|
||||
HELP: m/delete
|
||||
{ $values { "key" string } }
|
||||
{ $description
|
||||
"Deletes an item."
|
||||
} ;
|
||||
|
||||
HELP: m/append
|
||||
{ $values { "val" string } { "key" string } }
|
||||
{ $description
|
||||
"Appends the value to the specified item."
|
||||
} ;
|
||||
|
||||
HELP: m/prepend
|
||||
{ $values { "val" string } { "key" string } }
|
||||
{ $description
|
||||
"Prepends the value to the specified item."
|
||||
} ;
|
||||
|
||||
HELP: m/incr
|
||||
{ $values { "key" string } }
|
||||
{ $description
|
||||
"Increments the value of the specified item by 1."
|
||||
} ;
|
||||
|
||||
HELP: m/incr-val
|
||||
{ $values { "amt" "key" string } }
|
||||
{ $description
|
||||
"Increments the value of the specified item by the specified amount."
|
||||
} ;
|
||||
|
||||
HELP: m/decr
|
||||
{ $values { "key" string } }
|
||||
{ $description
|
||||
"Decrements the value of the specified item by 1."
|
||||
} ;
|
||||
|
||||
HELP: m/decr-val
|
||||
{ $values { "amt" "key" string } }
|
||||
{ $description
|
||||
"Decrements the value of the specified item by the specified amount."
|
||||
} ;
|
||||
|
||||
HELP: m/version
|
||||
{ $description
|
||||
"Retrieves the version of the " { $link memcached-server } "."
|
||||
} ;
|
||||
|
||||
HELP: m/noop
|
||||
{ $description
|
||||
"Used as a keep-alive. Also flushes any outstanding quiet gets."
|
||||
} ;
|
||||
|
||||
HELP: m/stats
|
||||
{ $values { "stats" sequence } }
|
||||
{ $description
|
||||
"Get various statistics about the " { $link memcached-server } "."
|
||||
} ;
|
||||
|
||||
HELP: m/flush
|
||||
{ $description
|
||||
"Deletes all the items in the cache now."
|
||||
} ;
|
||||
|
||||
HELP: m/flush-later
|
||||
{ $values { "seconds" integer } }
|
||||
{ $description
|
||||
"Deletes all the items in the cache sometime in the future."
|
||||
} ;
|
||||
|
||||
HELP: m/quit
|
||||
{ $description
|
||||
"Close the connection to the " { $link memcached-server } "."
|
||||
} ;
|
||||
|
||||
|
|
@ -0,0 +1,97 @@
|
|||
! Copyright (C) 2010 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: calendar math math.functions memcached memcached.private
|
||||
kernel sequences threads tools.test ;
|
||||
|
||||
IN: memcached.tests
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: not-found? ( quot -- )
|
||||
[ "key not found" = ] must-fail-with ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! test version
|
||||
[ t ] [ [ m/version ] with-memcached length 0 > ] unit-test
|
||||
|
||||
! test simple set get
|
||||
[ m/flush ] with-memcached
|
||||
[ "valuex" "x" m/set ] with-memcached
|
||||
[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
|
||||
! test flush
|
||||
[ m/flush ] with-memcached
|
||||
[ "valuex" "x" m/set "valuey" "y" m/set ] with-memcached
|
||||
[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
[ "valuey" ] [ [ "y" m/get ] with-memcached ] unit-test
|
||||
[ m/flush ] with-memcached
|
||||
[ [ "x" m/get ] with-memcached ] not-found?
|
||||
[ [ "y" m/get ] with-memcached ] not-found?
|
||||
|
||||
! test noop
|
||||
[ m/noop ] with-memcached
|
||||
|
||||
! test delete
|
||||
[ m/flush ] with-memcached
|
||||
[ "valuex" "x" m/set ] with-memcached
|
||||
[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
[ "x" m/delete ] with-memcached
|
||||
[ [ "x" m/get ] with-memcached ] not-found?
|
||||
|
||||
! test replace
|
||||
[ m/flush ] with-memcached
|
||||
[ [ "x" m/get ] with-memcached ] not-found?
|
||||
[ [ "ex" "x" m/replace ] with-memcached ] not-found?
|
||||
[ "ex" "x" m/add ] with-memcached
|
||||
[ "ex" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
[ "ex2" "x" m/replace ] with-memcached
|
||||
[ "ex2" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
|
||||
! test incr
|
||||
[ m/flush ] with-memcached
|
||||
[ 0 ] [ [ "x" m/incr ] with-memcached ] unit-test
|
||||
[ 1 ] [ [ "x" m/incr ] with-memcached ] unit-test
|
||||
[ 212 ] [ [ 211 "x" m/incr-val ] with-memcached ] unit-test
|
||||
[ 8589934804 ] [ [ 2 33 ^ "x" m/incr-val ] with-memcached ] unit-test
|
||||
|
||||
! test decr
|
||||
[ m/flush ] with-memcached
|
||||
[ "5" "x" m/set ] with-memcached
|
||||
[ 4 ] [ [ "x" m/decr ] with-memcached ] unit-test
|
||||
[ 0 ] [ [ 211 "x" m/decr-val ] with-memcached ] unit-test
|
||||
|
||||
! test timebombed flush
|
||||
[ m/flush ] with-memcached
|
||||
[ [ "x" m/get ] with-memcached ] not-found?
|
||||
[ "valuex" "x" m/set ] with-memcached
|
||||
[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
[ 2 m/flush-later ] with-memcached
|
||||
[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
3 seconds sleep
|
||||
[ [ "x" m/get ] with-memcached ] not-found?
|
||||
|
||||
! test append
|
||||
[ m/flush ] with-memcached
|
||||
[ "some" "x" m/set ] with-memcached
|
||||
[ "thing" "x" m/append ] with-memcached
|
||||
[ "something" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
|
||||
! test prepend
|
||||
[ m/flush ] with-memcached
|
||||
[ "some" "x" m/set ] with-memcached
|
||||
[ "thing" "x" m/prepend ] with-memcached
|
||||
[ "thingsome" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
|
||||
! test multi-get
|
||||
[ m/flush ] with-memcached
|
||||
[ H{ } ] [ [ { "x" "y" "z" } m/getseq ] with-memcached ] unit-test
|
||||
[ "5" "x" m/set ] with-memcached
|
||||
[ "valuex" "y" m/set ] with-memcached
|
||||
[ H{ { "x" "5" } { "y" "valuex" } } ]
|
||||
[ [ { "x" "y" "z" } m/getseq ] with-memcached ] unit-test
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,219 @@
|
|||
! Copyright (C) 2010 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: accessors arrays assocs byte-arrays combinators fry
|
||||
io io.encodings.binary io.sockets kernel make math math.parser
|
||||
namespaces pack random sequences strings ;
|
||||
|
||||
IN: memcached
|
||||
|
||||
! TODO:
|
||||
! - quiet commands
|
||||
! - CAS
|
||||
! - expirations
|
||||
! - initial-value for incr/decr
|
||||
|
||||
|
||||
SYMBOL: memcached-server
|
||||
"127.0.0.1" 11211 <inet> memcached-server set-global
|
||||
|
||||
: with-memcached ( quot -- )
|
||||
memcached-server get-global
|
||||
binary [ call ] with-client ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Commands
|
||||
CONSTANT: GET HEX: 00
|
||||
CONSTANT: SET HEX: 01
|
||||
CONSTANT: ADD HEX: 02
|
||||
CONSTANT: REPLACE HEX: 03
|
||||
CONSTANT: DELETE HEX: 04
|
||||
CONSTANT: INCR HEX: 05
|
||||
CONSTANT: DECR HEX: 06
|
||||
CONSTANT: QUIT HEX: 07
|
||||
CONSTANT: FLUSH HEX: 08
|
||||
CONSTANT: GETQ HEX: 09
|
||||
CONSTANT: NOOP HEX: 0A
|
||||
CONSTANT: VERSION HEX: 0B
|
||||
CONSTANT: GETK HEX: 0C
|
||||
CONSTANT: GETKQ HEX: 0D
|
||||
CONSTANT: APPEND HEX: 0E
|
||||
CONSTANT: PREPEND HEX: 0F
|
||||
CONSTANT: STAT HEX: 10
|
||||
CONSTANT: SETQ HEX: 11
|
||||
CONSTANT: ADDQ HEX: 12
|
||||
CONSTANT: REPLACEQ HEX: 13
|
||||
CONSTANT: DELETEQ HEX: 14
|
||||
CONSTANT: INCRQ HEX: 15
|
||||
CONSTANT: DECRQ HEX: 16
|
||||
CONSTANT: QUITQ HEX: 17
|
||||
CONSTANT: FLUSHQ HEX: 18
|
||||
CONSTANT: APPENDQ HEX: 19
|
||||
CONSTANT: PREPENDQ HEX: 1A
|
||||
|
||||
! Errors
|
||||
CONSTANT: NOT_FOUND HEX: 01
|
||||
CONSTANT: EXISTS HEX: 02
|
||||
CONSTANT: TOO_LARGE HEX: 03
|
||||
CONSTANT: INVALID_ARGS HEX: 04
|
||||
CONSTANT: NOT_STORED HEX: 05
|
||||
CONSTANT: NOT_NUMERIC HEX: 06
|
||||
CONSTANT: UNKNOWN_CMD HEX: 81
|
||||
CONSTANT: MEMORY HEX: 82
|
||||
|
||||
TUPLE: request cmd key val extra opaque cas ;
|
||||
|
||||
: <request> ( cmd -- request )
|
||||
"" "" "" random-32 0 \ request boa ;
|
||||
|
||||
: send-header ( request -- )
|
||||
{
|
||||
[ cmd>> ]
|
||||
[ key>> length ]
|
||||
[ extra>> length ]
|
||||
[
|
||||
[ key>> length ]
|
||||
[ extra>> length ]
|
||||
[ val>> length ] tri + +
|
||||
]
|
||||
[ opaque>> ]
|
||||
[ cas>> ]
|
||||
} cleave
|
||||
! magic, opcode, keylen, extralen, datatype, status,
|
||||
! bodylen, opaque, cas [ big-endian ]
|
||||
'[ HEX: 80 _ _ _ 0 0 _ _ _ ] "CCSCCSIIQ" pack-be write ;
|
||||
|
||||
: (send) ( str -- )
|
||||
[ >byte-array write ] unless-empty ;
|
||||
|
||||
: send-request ( request -- )
|
||||
{
|
||||
[ send-header ]
|
||||
[ extra>> (send) ]
|
||||
[ key>> (send) ]
|
||||
[ val>> (send) ]
|
||||
} cleave flush ;
|
||||
|
||||
: read-header ( -- header )
|
||||
"CCSCCSIIQ" [ packed-length read ] [ unpack-be ] bi ;
|
||||
|
||||
: check-magic ( header -- )
|
||||
first HEX: 81 = [ "bad magic" throw ] unless ;
|
||||
|
||||
: check-status ( header -- )
|
||||
[ 5 ] dip nth {
|
||||
{ NOT_FOUND [ "key not found" throw ] }
|
||||
{ EXISTS [ "key exists" throw ] }
|
||||
{ TOO_LARGE [ "value too large" throw ] }
|
||||
{ INVALID_ARGS [ "invalid arguments" throw ] }
|
||||
{ NOT_STORED [ "item not stored" throw ] }
|
||||
{ NOT_NUMERIC [ "value not numeric" throw ] }
|
||||
{ UNKNOWN_CMD [ "unknown command" throw ] }
|
||||
{ MEMORY [ "out of memory" throw ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
||||
: check-opaque ( opaque header -- ? )
|
||||
[ 7 ] dip nth = ;
|
||||
|
||||
: (read) ( n -- str )
|
||||
dup 0 > [ read >string ] [ drop "" ] if ;
|
||||
|
||||
: read-key ( header -- key )
|
||||
[ 2 ] dip nth (read) ;
|
||||
|
||||
: read-val ( header -- val )
|
||||
[ [ 6 ] dip nth ] [ [ 2 ] dip nth ] bi - (read) ;
|
||||
|
||||
: read-body ( header -- val key )
|
||||
{
|
||||
[ check-magic ]
|
||||
[ check-status ]
|
||||
[ read-key ]
|
||||
[ read-val ]
|
||||
} cleave swap ;
|
||||
|
||||
: read-response ( -- val key )
|
||||
read-header read-body ;
|
||||
|
||||
: submit ( request -- response )
|
||||
send-request read-response drop ;
|
||||
|
||||
: (cmd) ( key cmd -- request )
|
||||
<request> swap >>key ;
|
||||
|
||||
: (incr/decr) ( amt key cmd -- response )
|
||||
(cmd) swap '[ _ 0 0 ] "QQI" pack-be >>extra ! amt init exp
|
||||
submit "Q" unpack-be first ;
|
||||
|
||||
: (mutate) ( val key cmd -- )
|
||||
(cmd) swap >>val { 0 0 } "II" pack-be >>extra ! flags exp
|
||||
submit drop ;
|
||||
|
||||
: (cat) ( val key cmd -- )
|
||||
(cmd) swap >>val submit drop ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: m/version ( -- version ) VERSION <request> submit ;
|
||||
|
||||
: m/noop ( -- ) NOOP <request> submit drop ;
|
||||
|
||||
: m/incr-val ( amt key -- val ) INCR (incr/decr) ;
|
||||
|
||||
: m/incr ( key -- val ) 1 swap m/incr-val ;
|
||||
|
||||
: m/decr-val ( amt key -- val ) DECR (incr/decr) ;
|
||||
|
||||
: m/decr ( key -- val ) 1 swap m/decr-val ;
|
||||
|
||||
: m/get ( key -- val ) GET (cmd) submit 4 tail ;
|
||||
|
||||
: m/getq ( opaque key -- )
|
||||
GETQ (cmd) swap >>opaque send-request ;
|
||||
|
||||
: m/getseq ( keys -- vals )
|
||||
[ H{ } clone ] dip
|
||||
[ <enum> [ m/getq ] assoc-each ]
|
||||
[ length 10 + NOOP <request> swap >>opaque send-request ]
|
||||
[
|
||||
<enum> [
|
||||
assoc-size 10 + '[
|
||||
_ read-header [ check-opaque ] keep swap
|
||||
]
|
||||
] [
|
||||
'[
|
||||
[ read-body drop 4 tail ]
|
||||
[ [ 7 ] dip nth _ at ]
|
||||
bi pick set-at
|
||||
]
|
||||
] bi until drop
|
||||
] tri ;
|
||||
|
||||
: m/set ( val key -- ) SET (mutate) ;
|
||||
|
||||
: m/add ( val key -- ) ADD (mutate) ;
|
||||
|
||||
: m/replace ( val key -- ) REPLACE (mutate) ;
|
||||
|
||||
: m/delete ( key -- ) DELETE (cmd) submit drop ;
|
||||
|
||||
: m/append ( val key -- ) APPEND (cat) ;
|
||||
|
||||
: m/prepend ( val key -- ) PREPEND (cat) ;
|
||||
|
||||
: m/flush-later ( seconds -- )
|
||||
FLUSH <request> swap 1array "I" pack-be >>extra ! timebomb
|
||||
submit drop ;
|
||||
|
||||
: m/flush ( -- ) 0 m/flush-later ;
|
||||
|
||||
: m/stats ( -- stats )
|
||||
STAT <request> send-request
|
||||
[ read-response dup length 0 > ]
|
||||
[ swap 2array ] produce 2nip ;
|
||||
|
||||
: m/quit ( -- ) QUIT <request> submit drop ;
|
||||
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Provides access to memcached, a high-performance, distributed memory object caching system.
|
||||
|
|
@ -27,7 +27,7 @@ rectangle new 10 >>width 20 >>height area .
|
|||
----
|
||||
USING: accessors smtp ;
|
||||
|
||||
<email>
|
||||
<email>
|
||||
"john@foobar.com" >>from
|
||||
{ "jane@foobar.com" } >>to
|
||||
"Up for lunch?" >>subject
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1 @@
|
|||
Query API for Wolfram Alpha
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (C) 2011 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: accessors colors.constants formatting http http.client
|
||||
images.gif images.http io io.styles kernel namespaces sequences
|
||||
splitting ui urls.encoding xml xml.data xml.traversal ;
|
||||
|
||||
IN: wolfram-alpha
|
||||
|
||||
SYMBOL: wolfram-api-id
|
||||
|
||||
! "XXXXXX-XXXXXXXXXX" wolfram-api-id set-global
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: query ( query -- xml )
|
||||
url-encode wolfram-api-id get-global
|
||||
"http://api.wolframalpha.com/v2/query?input=%s&appid=%s"
|
||||
sprintf http-get nip string>xml ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: wolfram-image. ( query -- )
|
||||
query "pod" tags-named [
|
||||
[
|
||||
"title" attr "%s:\n" sprintf H{
|
||||
{ foreground COLOR: slate-gray }
|
||||
{ font-name "sans-serif" }
|
||||
{ font-style bold }
|
||||
} format
|
||||
] [
|
||||
"img" deep-tags-named [
|
||||
"src" attr " " write http-image.
|
||||
] each
|
||||
] bi
|
||||
] each ;
|
||||
|
||||
: wolfram-text. ( query -- )
|
||||
query "pod" tags-named [
|
||||
[ "title" attr "%s:\n" printf ]
|
||||
[
|
||||
"plaintext" deep-tags-named [
|
||||
children>string string-lines
|
||||
[ " %s\n" printf ] each
|
||||
] each
|
||||
] bi
|
||||
] each ;
|
||||
|
||||
: wolfram. ( query -- )
|
||||
ui-running? [ wolfram-image. ] [ wolfram-text. ] if ;
|
||||
Loading…
Reference in New Issue