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

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

db4
Slava Pestov 2009-03-14 23:01:31 -05:00
parent 4ca90e2a6a 845158fffd
commit 87db3ae85e
7 changed files with 284 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/calendar/calendar-docs.factor
View File

@ -36,7 +36,7 @@ HELP: month-name
{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
HELP: month-abbreviations
{ $values { "array" array } }
{ $values { "value" array } }
{ $description "Returns an array with the English abbreviated names of all the months." }
{ $warning "Do not use this array for looking up a month name directly. Use month-abbreviation instead." } ;
@ -54,7 +54,7 @@ HELP: day-name
{ $description "Looks up the day name and returns it as a string." } ;
HELP: day-abbreviations2
{ $values { "array" array } }
{ $values { "value" array } }
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ;
HELP: day-abbreviation2
@ -62,7 +62,7 @@ HELP: day-abbreviation2
{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ;
HELP: day-abbreviations3
{ $values { "array" array } }
{ $values { "value" array } }
{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ;
HELP: day-abbreviation3

143
basis/images/bitmap/bitmap.factor
View File

@ -6,14 +6,23 @@ kernel macros math math.bitwise math.functions namespaces sequences
strings images endian summary ;
IN: images.bitmap
TUPLE: bitmap-image < image
magic size reserved offset header-length width
: assert-sequence= ( a b -- )
2dup sequence= [ 2drop ] [ assert ] if ;
: read2 ( -- n ) 2 read le> ;
: read4 ( -- n ) 4 read le> ;
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;
TUPLE: bitmap-image < image ;
! Used to construct the final bitmap-image
TUPLE: loading-bitmap
size reserved offset header-length width
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index ;
! Currently can only handle 24/32bit bitmaps.
! Handles row-reversed bitmaps (their height is negative)
ERROR: bitmap-magic magic ;
M: bitmap-magic summary
@ -21,37 +30,31 @@ M: bitmap-magic summary
<PRIVATE
: array-copy ( bitmap array -- bitmap array' )
over size-image>> abs memory>byte-array ;
: 8bit>buffer ( bitmap -- array )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ;
ERROR: bmp-not-supported n ;
: raw-bitmap>buffer ( bitmap -- array )
: reverse-lines ( byte-array width -- byte-array )
3 * <sliced-groups> <reversed> concat ; inline
: raw-bitmap>seq ( loading-bitmap -- array )
dup bit-count>>
{
{ 32 [ color-index>> ] }
{ 24 [ color-index>> ] }
{ 16 [ bmp-not-supported ] }
{ 8 [ 8bit>buffer ] }
{ 4 [ bmp-not-supported ] }
{ 2 [ bmp-not-supported ] }
{ 1 [ bmp-not-supported ] }
{ 24 [ [ color-index>> ] [ width>> ] bi reverse-lines ] }
{ 8 [ [ 8bit>buffer ] [ width>> ] bi reverse-lines ] }
[ bmp-not-supported ]
} case >byte-array ;
: read2 ( -- n ) 2 read le> ;
: read4 ( -- n ) 4 read le> ;
: parse-file-header ( bitmap -- bitmap )
2 read dup "BM" sequence= [ bitmap-magic ] unless >>magic
: parse-file-header ( loading-bitmap -- loading-bitmap )
2 read "BM" assert-sequence=
read4 >>size
read4 >>reserved
read4 >>offset ;
: parse-bitmap-header ( bitmap -- bitmap )
: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
read4 >>header-length
read4 >>width
read4 >>height
@ -64,10 +67,10 @@ ERROR: bmp-not-supported n ;
read4 >>color-used
read4 >>color-important ;
: rgb-quads-length ( bitmap -- n )
: rgb-quads-length ( loading-bitmap -- n )
[ offset>> 14 - ] [ header-length>> ] bi - ;
: color-index-length ( bitmap -- n )
: color-index-length ( loading-bitmap -- n )
{
[ width>> ]
[ planes>> * ]
@ -75,21 +78,18 @@ ERROR: bmp-not-supported n ;
[ height>> abs * ]
} cleave ;
: parse-bitmap ( bitmap -- bitmap )
: parse-bitmap ( loading-bitmap -- loading-bitmap )
dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index ;
: load-bitmap-data ( path bitmap -- bitmap )
: load-bitmap-data ( path loading-bitmap -- loading-bitmap )
[ binary ] dip '[
_ parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader ;
: process-bitmap-data ( bitmap -- bitmap )
dup raw-bitmap>buffer >>bitmap ;
ERROR: unknown-component-order bitmap ;
: bitmap>component-order ( bitmap -- object )
: bitmap>component-order ( loading-bitmap -- object )
bit-count>> {
{ 32 [ BGRA ] }
{ 24 [ BGR ] }
@ -97,61 +97,66 @@ ERROR: unknown-component-order bitmap ;
[ unknown-component-order ]
} case ;
: fill-image-slots ( bitmap -- bitmap )
dup {
: loading-bitmap>bitmap-image ( loading-bitmap -- bitmap-image )
[ bitmap-image new ] dip
{
[ raw-bitmap>seq >>bitmap ]
[ [ width>> ] [ height>> ] bi 2array >>dim ]
[ bitmap>component-order >>component-order ]
[ bitmap>> >>bitmap ]
} cleave ;
M: bitmap-image load-image* ( path bitmap -- bitmap )
load-bitmap-data process-bitmap-data
fill-image-slots ;
MACRO: (nbits>bitmap) ( bits -- )
[ -3 shift ] keep '[
bitmap-image new
2over * _ * >>size-image
swap >>height
swap >>width
swap array-copy [ >>bitmap ] [ >>color-index ] bi
_ >>bit-count fill-image-slots
t >>upside-down?
] ;
: bgr>bitmap ( array height width -- bitmap )
24 (nbits>bitmap) ;
: bgra>bitmap ( array height width -- bitmap )
32 (nbits>bitmap) ;
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
drop loading-bitmap new
load-bitmap-data
loading-bitmap>bitmap-image ;
PRIVATE>
: save-bitmap ( bitmap path -- )
: bitmap>color-index ( bitmap-array -- byte-array )
4 <sliced-groups> [ 3 head-slice <reversed> ] map B{ } join ; inline
: save-bitmap ( image path -- )
binary [
B{ CHAR: B CHAR: M } write
[
color-index>> length 14 + 40 + write4
bitmap>> bitmap>color-index length 14 + 40 + write4
0 write4
54 write4
40 write4
] [
{
[ width>> write4 ]
[ height>> write4 ]
[ planes>> 1 or write2 ]
[ bit-count>> 24 or write2 ]
[ compression>> 0 or write4 ]
[ size-image>> write4 ]
[ x-pels>> 0 or write4 ]
[ y-pels>> 0 or write4 ]
[ color-used>> 0 or write4 ]
[ color-important>> 0 or write4 ]
[ rgb-quads>> write ]
[ color-index>> write ]
! width height
[ dim>> first2 [ write4 ] bi@ ]
! planes
[ drop 1 write2 ]
! bit-count
[ drop 24 write2 ]
! compression
[ drop 0 write4 ]
! size-image
[ bitmap>> bitmap>color-index length write4 ]
! x-pels
[ drop 0 write4 ]
! y-pels
[ drop 0 write4 ]
! color-used
[ drop 0 write4 ]
! color-important
[ drop 0 write4 ]
! rgb-quads
[
[ bitmap>> bitmap>color-index ] [ dim>> first ] bi
reverse-lines write
]
} cleave
] bi
] with-file-writer ;

18
basis/smtp/smtp-docs.factor
View File

@ -73,6 +73,20 @@ HELP: send-email
}
} ;
ARTICLE: "smtp-gmail" "Setting up SMTP with gmail"
"If you plan to send all email from the same address, then setting variables in the global namespace is the best option. The code example below does this approach and is meant to go in your " { $link "factor-boot-rc" } "." $nl
"Several variables need to be set for sending outgoing mail through gmail. First, we set the login and password to a " { $link <plain-auth> } " tuple with our login. Next, we set the gmail server address with an " { $link <inet> } " object. Finally, we tell the SMTP library to use a secure connection."
{ $code
"USING: smtp namespaces io.sockets ;"
""
"\"my.gmail.address@gmail.com\" \"secret-password\" <plain-auth> smtp-auth set-global"
""
"\"smtp.gmail.com\" 587 <inet> smtp-server set-global"
""
"t smtp-tls? set-global"
} ;
ARTICLE: "smtp" "SMTP client library"
"The " { $vocab-link "smtp" } " vocabulary sends e-mail via an SMTP server."
$nl
@ -89,6 +103,8 @@ $nl
{ $subsection email }
{ $subsection <email> }
"Sending an email:"
{ $subsection send-email } ;
{ $subsection send-email }
"More topics:"
{ $subsection "smtp-gmail" } ;
ABOUT: "smtp"

18
basis/tools/scaffold/scaffold.factor
View File

@ -5,7 +5,7 @@ io.encodings.utf8 hashtables kernel namespaces sequences
vocabs.loader io combinators calendar accessors math.parser
io.streams.string ui.tools.operations quotations strings arrays
prettyprint words vocabs sorting sets classes math alien urls
splitting ascii combinators.short-circuit ;
splitting ascii combinators.short-circuit alarms words.symbol ;
IN: tools.scaffold
SYMBOL: developer-name
@ -116,6 +116,7 @@ ERROR: no-vocab vocab ;
{ "ch" "a character" }
{ "word" word }
{ "array" array }
{ "alarm" alarm }
{ "duration" duration }
{ "path" "a pathname string" }
{ "vocab" "a vocabulary specifier" }
@ -134,7 +135,7 @@ ERROR: no-vocab vocab ;
: ($values.) ( array -- )
[
" { " write
"{ " write
dup array? [ first ] when
dup lookup-type [
[ unparse write bl ]
@ -162,15 +163,26 @@ ERROR: no-vocab vocab ;
] if
] when* ;
: symbol-description. ( word -- )
drop
"{ $var-description \"\" } ;" print ;
: $description. ( word -- )
drop
"{ $description \"\" } ;" print ;
: docs-body. ( word/symbol -- )
dup symbol? [
symbol-description.
] [
[ $values. ] [ $description. ] bi
] if ;
: docs-header. ( word -- )
"HELP: " write name>> print ;
: (help.) ( word -- )
[ docs-header. ] [ $values. ] [ $description. ] tri ;
[ docs-header. ] [ docs-body. ] bi ;
: interesting-words ( vocab -- array )
words

1
extra/site-watcher/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

60
extra/site-watcher/site-watcher-docs.factor Normal file
View File

@ -0,0 +1,60 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs help.markup help.syntax kernel urls alarms calendar ;
IN: site-watcher
HELP: run-site-watcher
{ $description "Starts the site-watcher on the assoc stored in " { $link sites } "." } ;
HELP: running-site-watcher
{ $var-description "A symbol storing the alarm of a running site-watcher if started with the " { $link run-site-watcher } " word. To prevent multiple site-watchers from running, this variable is checked before allowing another site-watcher to start." } ;
HELP: site-watcher-from
{ $var-description "The email address from which site-watcher sends emails." } ;
HELP: sites
{ $var-description "A symbol storing an assoc of URLs, data about a site, and who to notify if a site goes down." } ;
HELP: watch-site
{ $values
{ "emails" "a string containing an email address, or an array of such" }
{ "url" url }
}
{ $description "Adds a new site to the watch assoc stored in " { $link sites } ", or adds email addresses to an already watched site." } ;
HELP: watch-sites
{ $values
{ "assoc" assoc }
{ "alarm" alarm }
}
{ $description "Runs the site-watcher on the input assoc and returns the alarm that times the site check loop. This alarm may be turned off with " { $link cancel-alarm } ", thus stopping the site-watcher." } ;
HELP: site-watcher-frequency
{ $var-description "A " { $link duration } " specifying how long to wait between checking sites." } ;
HELP: unwatch-site
{ $values
{ "emails" "a string containing an email, or an array of such" }
{ "url" url }
}
{ $description "Removes an email address from being notified when a site's goes down. If this email was the last one watching the site, removes the site as well." } ;
HELP: delete-site
{ $values
{ "url" url }
}
{ $description "Removes a watched site from the " { $link sites } " assoc." } ;
ARTICLE: "site-watcher" "Site watcher"
"The " { $vocab-link "site-watcher" } " vocabulary monitors websites and sends email when a site goes down or comes up." $nl
"To monitor a site:"
{ $subsection watch-site }
"To stop email addresses from being notified if a site's status changes:"
{ $subsection unwatch-site }
"To stop monitoring a site for all email addresses:"
{ $subsection delete-site }
"To run site-watcher using the sites variable:"
{ $subsection run-site-watcher }
;
ABOUT: "site-watcher"

114
extra/site-watcher/site-watcher.factor Normal file
View File

@ -0,0 +1,114 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alarms assocs calendar combinators
continuations fry http.client io.streams.string kernel init
namespaces prettyprint smtp arrays sequences math math.parser
strings sets ;
IN: site-watcher
SYMBOL: sites
SYMBOL: site-watcher-from
sites [ H{ } clone ] initialize
TUPLE: watching emails url last-up up? send-email? error ;
<PRIVATE
: ?1array ( array/object -- array )
dup array? [ 1array ] unless ; inline
: <watching> ( emails url -- watching )
watching new
swap >>url
swap ?1array >>emails
now >>last-up
t >>up? ;
ERROR: not-watching-site url status ;
: set-site-flags ( watching new-up? -- watching )
[ over up?>> = [ t >>send-email? ] unless ] keep >>up? ;
: site-bad ( watching error -- )
>>error f set-site-flags drop ;
: site-good ( watching -- )
f >>error
t set-site-flags
now >>last-up drop ;
: check-sites ( assoc -- )
[
swap '[ _ http-get 2drop site-good ] [ site-bad ] recover
] assoc-each ;
: site-up-email ( email watching -- email )
last-up>> now swap time- duration>minutes 60 /mod
[ >integer number>string ] bi@
[ " hours, " append ] [ " minutes" append ] bi* append
"Site was down for (at least): " prepend >>body ;
: ?unparse ( string/object -- string )
dup string? [ unparse ] unless ; inline
: site-down-email ( email watching -- email )
error>> ?unparse >>body ;
: send-report ( watching -- )
[ <email> ] dip
{
[ emails>> >>to ]
[ drop site-watcher-from get "factor.site.watcher@gmail.com" or >>from ]
[ dup up?>> [ site-up-email ] [ site-down-email ] if ]
[ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ]
[ f >>send-email? drop ]
} cleave send-email ;
: report-sites ( assoc -- )
[ nip send-email?>> ] assoc-filter
[ nip send-report ] assoc-each ;
PRIVATE>
SYMBOL: site-watcher-frequency
site-watcher-frequency [ 5 minutes ] initialize
: watch-sites ( assoc -- alarm )
'[
_ [ check-sites ] [ report-sites ] bi
] site-watcher-frequency get every ;
: watch-site ( emails url -- )
sites get ?at [
[ [ ?1array ] dip append prune ] change-emails drop
] [
<watching> dup url>> sites get set-at
] if ;
: delete-site ( url -- )
sites get delete-at ;
: unwatch-site ( emails url -- )
[ ?1array ] dip
sites get ?at [
[ diff ] change-emails dup emails>> empty? [
url>> delete-site
] [
drop
] if
] [
nip delete-site
] if ;
SYMBOL: running-site-watcher
: run-site-watcher ( -- )
running-site-watcher get-global [
sites get-global watch-sites running-site-watcher set-global
] unless ;
[ f running-site-watcher set-global ] "site-watcher" add-init-hook
MAIN: run-site-watcher